{-# LANGUAGE CPP #-}
module Distribution.Client.Install (
install,
makeInstallContext,
makeInstallPlan,
processInstallPlan,
InstallArgs,
InstallContext,
pruneInstallPlan
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Utils.Generic(safeLast)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Control.Exception as Exception
( bracket, catches, Handler(Handler), handleJust )
import System.Directory
( getTemporaryDirectory, doesDirectoryExist, doesFileExist,
createDirectoryIfMissing, removeFile, renameDirectory,
getDirectoryContents )
import System.FilePath
( (</>), (<.>), equalFilePath, takeDirectory )
import System.IO
( openFile, IOMode(AppendMode), hClose )
import System.IO.Error
( isDoesNotExistError, ioeGetFileName )
import Distribution.Client.Targets
import Distribution.Client.Configure
( chooseCabalVersion, configureSetupScript, checkConfigExFlags )
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
( Solver(..) )
import Distribution.Client.FetchUtils
import Distribution.Client.HttpUtils
( HttpTransport (..) )
import Distribution.Solver.Types.PackageFixedDeps
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackagesAtIndexState, getInstalledPackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import Distribution.Client.Setup
( GlobalFlags(..), RepoContext(..)
, ConfigFlags(..), configureCommand, filterConfigureFlags
, ConfigExFlags(..), InstallFlags(..)
, filterTestFlags )
import Distribution.Client.Config
( getCabalDir, defaultUserInstall )
import Distribution.Client.Tar (extractTarGzFile)
import Distribution.Client.Types as Source
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.BuildReports.Anonymous (showBuildReport)
import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
import qualified Distribution.Client.BuildReports.Storage as BuildReports
( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )
import qualified Distribution.Client.InstallSymlink as InstallSymlink
( symlinkBinaries )
import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Client.JobControl
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex
import Distribution.Solver.Types.PkgConfigDb
( PkgConfigDb, readPkgConfigDb )
import Distribution.Solver.Types.SourcePackage as SourcePackage
import Distribution.Utils.NubList
import Distribution.Simple.Compiler
( CompilerId(..), Compiler(compilerId), compilerFlavor
, CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack )
import Distribution.Simple.Program (ProgramDb)
import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Setup
( haddockCommand, HaddockFlags(..)
, buildCommand, BuildFlags(..), emptyBuildFlags
, TestFlags, BenchmarkFlags
, toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref )
import qualified Distribution.Simple.Setup as Cabal
( Flag(..)
, copyCommand, CopyFlags(..), emptyCopyFlags
, registerCommand, RegisterFlags(..), emptyRegisterFlags
, testCommand, TestFlags(..) )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, writeFileAtomic )
import Distribution.Simple.InstallDirs as InstallDirs
( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
, initialPathTemplateEnv, installDirsTemplateEnv )
import Distribution.Simple.Configure (interpretPackageDbFlags)
import Distribution.Simple.Register (registerPackage, defaultRegisterOptions)
import Distribution.Package
( PackageIdentifier(..), PackageId, packageName, packageVersion
, Package(..), HasMungedPackageId(..), HasUnitId(..)
, UnitId )
import Distribution.Types.GivenComponent
( GivenComponent(..) )
import Distribution.Types.PackageVersionConstraint
( PackageVersionConstraint(..), thisPackageVersionConstraint )
import Distribution.Types.MungedPackageId
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription, GenericPackageDescription(..) )
import Distribution.Types.Flag
( PackageFlag(..), FlagAssignment, mkFlagAssignment
, showFlagAssignment, diffFlagAssignment, nullFlagAssignment )
import Distribution.PackageDescription.Configuration
( finalizePD )
import Distribution.Version
( Version, VersionRange, foldVersionRange )
import Distribution.Simple.Utils as Utils
( notice, info, warn, debug, debugNoWrap, die'
, withTempDirectory )
import Distribution.Client.Utils
( determineNumJobs, logDirChange, mergeBy, MergeResult(..)
, ProgressPhase(..), progressMessage )
import Distribution.System
( Platform, OS(Windows), buildOS, buildPlatform )
import Distribution.Verbosity as Verbosity
( modifyVerbosity, normal, verbose )
import Distribution.Simple.BuildPaths ( exeExtension )
import qualified Data.ByteString as BS
install
:: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> BenchmarkFlags
-> [UserTarget]
-> IO ()
install :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> BenchmarkFlags
-> [UserTarget]
-> IO ()
install Verbosity
verbosity PackageDBStack
packageDBs RepoContext
repos Compiler
comp Platform
platform ProgramDb
progdb
GlobalFlags
globalFlags ConfigFlags
configFlags ConfigExFlags
configExFlags InstallFlags
installFlags
HaddockFlags
haddockFlags TestFlags
testFlags BenchmarkFlags
benchmarkFlags [UserTarget]
userTargets0 = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (InstallFlags -> Flag String
installRootCmd InstallFlags
installFlags Flag String -> Flag String -> Bool
forall a. Eq a => a -> a -> Bool
== Flag String
forall a. Flag a
Cabal.NoFlag) (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
"--root-cmd is no longer supported, "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"see https://github.com/haskell/cabal/issues/3353"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (if you didn't type --root-cmd, comment out root-cmd"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in your ~/.cabal/config file)"
let userOrSandbox :: Bool
userOrSandbox = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
userOrSandbox (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
"the --global flag is deprecated -- "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"it is generally considered a bad idea to install packages "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"into the global store"
InstallContext
installContext <- Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext
makeInstallContext Verbosity
verbosity InstallArgs
args ([UserTarget] -> Maybe [UserTarget]
forall a. a -> Maybe a
Just [UserTarget]
userTargets0)
Either String SolverInstallPlan
planResult <- (String
-> IO (Either String SolverInstallPlan)
-> IO (Either String SolverInstallPlan))
-> (String -> IO (Either String SolverInstallPlan))
-> (SolverInstallPlan -> IO (Either String SolverInstallPlan))
-> Progress String String SolverInstallPlan
-> IO (Either String SolverInstallPlan)
forall step a fail done.
(step -> a -> a)
-> (fail -> a) -> (done -> a) -> Progress step fail done -> a
foldProgress String
-> IO (Either String SolverInstallPlan)
-> IO (Either String SolverInstallPlan)
forall b. String -> IO b -> IO b
logMsg (Either String SolverInstallPlan
-> IO (Either String SolverInstallPlan)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String SolverInstallPlan
-> IO (Either String SolverInstallPlan))
-> (String -> Either String SolverInstallPlan)
-> String
-> IO (Either String SolverInstallPlan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String SolverInstallPlan
forall a b. a -> Either a b
Left) (Either String SolverInstallPlan
-> IO (Either String SolverInstallPlan)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String SolverInstallPlan
-> IO (Either String SolverInstallPlan))
-> (SolverInstallPlan -> Either String SolverInstallPlan)
-> SolverInstallPlan
-> IO (Either String SolverInstallPlan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolverInstallPlan -> Either String SolverInstallPlan
forall a b. b -> Either a b
Right) (Progress String String SolverInstallPlan
-> IO (Either String SolverInstallPlan))
-> IO (Progress String String SolverInstallPlan)
-> IO (Either String SolverInstallPlan)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
Verbosity
-> InstallArgs
-> InstallContext
-> IO (Progress String String SolverInstallPlan)
makeInstallPlan Verbosity
verbosity InstallArgs
args InstallContext
installContext
case Either String SolverInstallPlan
planResult of
Left String
message -> do
Verbosity -> InstallArgs -> InstallContext -> String -> IO ()
reportPlanningFailure Verbosity
verbosity InstallArgs
args InstallContext
installContext String
message
String -> IO ()
forall a. String -> IO a
die'' String
message
Right SolverInstallPlan
installPlan ->
Verbosity
-> InstallArgs -> InstallContext -> SolverInstallPlan -> IO ()
processInstallPlan Verbosity
verbosity InstallArgs
args InstallContext
installContext SolverInstallPlan
installPlan
where
args :: InstallArgs
args :: InstallArgs
args = (PackageDBStack
packageDBs, RepoContext
repos, Compiler
comp, Platform
platform, ProgramDb
progdb,
GlobalFlags
globalFlags, ConfigFlags
configFlags, ConfigExFlags
configExFlags,
InstallFlags
installFlags, HaddockFlags
haddockFlags, TestFlags
testFlags, BenchmarkFlags
benchmarkFlags)
die'' :: String -> IO a
die'' = Verbosity -> String -> IO a
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity
logMsg :: String -> IO b -> IO b
logMsg String
message IO b
rest = Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity String
message IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
rest
type InstallContext = ( InstalledPackageIndex, SourcePackageDb
, PkgConfigDb
, [UserTarget], [PackageSpecifier UnresolvedSourcePackage]
, HttpTransport )
type InstallArgs = ( PackageDBStack
, RepoContext
, Compiler
, Platform
, ProgramDb
, GlobalFlags
, ConfigFlags
, ConfigExFlags
, InstallFlags
, HaddockFlags
, TestFlags
, BenchmarkFlags )
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
-> IO InstallContext
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext
makeInstallContext Verbosity
verbosity
(PackageDBStack
packageDBs, RepoContext
repoCtxt, Compiler
comp, Platform
_, ProgramDb
progdb,
GlobalFlags
_, ConfigFlags
_, ConfigExFlags
configExFlags, InstallFlags
installFlags, HaddockFlags
_, TestFlags
_, BenchmarkFlags
_) Maybe [UserTarget]
mUserTargets = do
let idxState :: Maybe TotalIndexState
idxState = Flag TotalIndexState -> Maybe TotalIndexState
forall a. Flag a -> Maybe a
flagToMaybe (InstallFlags -> Flag TotalIndexState
installIndexState InstallFlags
installFlags)
InstalledPackageIndex
installedPkgIndex <- Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStack
packageDBs ProgramDb
progdb
(SourcePackageDb
sourcePkgDb, TotalIndexState
_, ActiveRepos
_) <- Verbosity
-> RepoContext
-> Maybe TotalIndexState
-> Maybe ActiveRepos
-> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
getSourcePackagesAtIndexState Verbosity
verbosity RepoContext
repoCtxt Maybe TotalIndexState
idxState Maybe ActiveRepos
forall a. Maybe a
Nothing
PkgConfigDb
pkgConfigDb <- Verbosity -> ProgramDb -> IO PkgConfigDb
readPkgConfigDb Verbosity
verbosity ProgramDb
progdb
Verbosity
-> InstalledPackageIndex
-> PackageIndex UnresolvedSourcePackage
-> ConfigExFlags
-> IO ()
forall pkg.
Package pkg =>
Verbosity
-> InstalledPackageIndex
-> PackageIndex pkg
-> ConfigExFlags
-> IO ()
checkConfigExFlags Verbosity
verbosity InstalledPackageIndex
installedPkgIndex
(SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
sourcePkgDb) ConfigExFlags
configExFlags
HttpTransport
transport <- RepoContext -> IO HttpTransport
repoContextGetTransport RepoContext
repoCtxt
([UserTarget]
userTargets, [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers) <- case Maybe [UserTarget]
mUserTargets of
Maybe [UserTarget]
Nothing ->
([UserTarget], [PackageSpecifier UnresolvedSourcePackage])
-> IO ([UserTarget], [PackageSpecifier UnresolvedSourcePackage])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
Just [UserTarget]
userTargets0 -> do
let userTargets :: [UserTarget]
userTargets | [UserTarget] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UserTarget]
userTargets0 = [String -> UserTarget
UserTargetLocalDir String
"."]
| Bool
otherwise = [UserTarget]
userTargets0
[PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers <- Verbosity
-> RepoContext
-> PackageIndex UnresolvedSourcePackage
-> [UserTarget]
-> IO [PackageSpecifier UnresolvedSourcePackage]
forall pkg.
Package pkg =>
Verbosity
-> RepoContext
-> PackageIndex pkg
-> [UserTarget]
-> IO [PackageSpecifier UnresolvedSourcePackage]
resolveUserTargets Verbosity
verbosity RepoContext
repoCtxt
(SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
sourcePkgDb)
[UserTarget]
userTargets
([UserTarget], [PackageSpecifier UnresolvedSourcePackage])
-> IO ([UserTarget], [PackageSpecifier UnresolvedSourcePackage])
forall (m :: * -> *) a. Monad m => a -> m a
return ([UserTarget]
userTargets, [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers)
InstallContext -> IO InstallContext
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex
installedPkgIndex, SourcePackageDb
sourcePkgDb, PkgConfigDb
pkgConfigDb, [UserTarget]
userTargets
,[PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers, HttpTransport
transport)
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> IO (Progress String String SolverInstallPlan)
makeInstallPlan :: Verbosity
-> InstallArgs
-> InstallContext
-> IO (Progress String String SolverInstallPlan)
makeInstallPlan Verbosity
verbosity
(PackageDBStack
_, RepoContext
_, Compiler
comp, Platform
platform,ProgramDb
_,
GlobalFlags
_, ConfigFlags
configFlags, ConfigExFlags
configExFlags, InstallFlags
installFlags,
HaddockFlags
_, TestFlags
_, BenchmarkFlags
_)
(InstalledPackageIndex
installedPkgIndex, SourcePackageDb
sourcePkgDb, PkgConfigDb
pkgConfigDb,
[UserTarget]
_, [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers, HttpTransport
_) = do
Solver
solver <- Verbosity -> PreSolver -> CompilerInfo -> IO Solver
chooseSolver Verbosity
verbosity (Flag PreSolver -> PreSolver
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigExFlags -> Flag PreSolver
configSolver ConfigExFlags
configExFlags))
(Compiler -> CompilerInfo
compilerInfo Compiler
comp)
Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Resolving dependencies..."
Progress String String SolverInstallPlan
-> IO (Progress String String SolverInstallPlan)
forall (m :: * -> *) a. Monad m => a -> m a
return (Progress String String SolverInstallPlan
-> IO (Progress String String SolverInstallPlan))
-> Progress String String SolverInstallPlan
-> IO (Progress String String SolverInstallPlan)
forall a b. (a -> b) -> a -> b
$ Verbosity
-> Compiler
-> Platform
-> Solver
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> Progress String String SolverInstallPlan
planPackages Verbosity
verbosity Compiler
comp Platform
platform Solver
solver
ConfigFlags
configFlags ConfigExFlags
configExFlags InstallFlags
installFlags
InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb PkgConfigDb
pkgConfigDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> SolverInstallPlan
-> IO ()
processInstallPlan :: Verbosity
-> InstallArgs -> InstallContext -> SolverInstallPlan -> IO ()
processInstallPlan Verbosity
verbosity
args :: InstallArgs
args@(PackageDBStack
_,RepoContext
_, Compiler
_, Platform
_, ProgramDb
_, GlobalFlags
_, ConfigFlags
configFlags, ConfigExFlags
_, InstallFlags
installFlags, HaddockFlags
_, TestFlags
_, BenchmarkFlags
_)
(InstalledPackageIndex
installedPkgIndex, SourcePackageDb
sourcePkgDb, PkgConfigDb
_,
[UserTarget]
userTargets, [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers, HttpTransport
_) SolverInstallPlan
installPlan0 = do
Verbosity
-> InstalledPackageIndex
-> InstallPlan
-> SourcePackageDb
-> InstallFlags
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO ()
checkPrintPlan Verbosity
verbosity InstalledPackageIndex
installedPkgIndex InstallPlan
installPlan SourcePackageDb
sourcePkgDb
InstallFlags
installFlags [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
dryRun Bool -> Bool -> Bool
|| Bool
nothingToInstall) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
BuildOutcomes
buildOutcomes <- Verbosity
-> InstallArgs
-> InstalledPackageIndex
-> InstallPlan
-> IO BuildOutcomes
performInstallations Verbosity
verbosity
InstallArgs
args InstalledPackageIndex
installedPkgIndex InstallPlan
installPlan
Verbosity
-> InstallArgs
-> [UserTarget]
-> InstallPlan
-> BuildOutcomes
-> IO ()
postInstallActions Verbosity
verbosity InstallArgs
args [UserTarget]
userTargets InstallPlan
installPlan BuildOutcomes
buildOutcomes
where
installPlan :: InstallPlan
installPlan = ConfigFlags -> SolverInstallPlan -> InstallPlan
InstallPlan.configureInstallPlan ConfigFlags
configFlags SolverInstallPlan
installPlan0
dryRun :: Bool
dryRun = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDryRun InstallFlags
installFlags)
nothingToInstall :: Bool
nothingToInstall = [GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (([GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)],
Processing)
-> [GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)]
forall a b. (a, b) -> a
fst (InstallPlan
-> ([GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)],
Processing)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
InstallPlan.ready InstallPlan
installPlan))
planPackages :: Verbosity
-> Compiler
-> Platform
-> Solver
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> Progress String String SolverInstallPlan
planPackages :: Verbosity
-> Compiler
-> Platform
-> Solver
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> Progress String String SolverInstallPlan
planPackages Verbosity
verbosity Compiler
comp Platform
platform Solver
solver
ConfigFlags
configFlags ConfigExFlags
configExFlags InstallFlags
installFlags
InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb PkgConfigDb
pkgConfigDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers =
Platform
-> CompilerInfo
-> PkgConfigDb
-> Solver
-> DepResolverParams
-> Progress String String SolverInstallPlan
resolveDependencies
Platform
platform (Compiler -> CompilerInfo
compilerInfo Compiler
comp) PkgConfigDb
pkgConfigDb
Solver
solver
DepResolverParams
resolverParams
Progress String String SolverInstallPlan
-> (SolverInstallPlan -> Progress String String SolverInstallPlan)
-> Progress String String SolverInstallPlan
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= if Bool
onlyDeps then [PackageSpecifier UnresolvedSourcePackage]
-> SolverInstallPlan -> Progress String String SolverInstallPlan
forall targetpkg.
Package targetpkg =>
[PackageSpecifier targetpkg]
-> SolverInstallPlan -> Progress String String SolverInstallPlan
pruneInstallPlan [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers else SolverInstallPlan -> Progress String String SolverInstallPlan
forall (m :: * -> *) a. Monad m => a -> m a
return
where
resolverParams :: DepResolverParams
resolverParams =
Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps (if Int
maxBackjumps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Maybe Int
forall a. Maybe a
Nothing
else Int -> Maybe Int
forall a. a -> Maybe a
Just Int
maxBackjumps)
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndependentGoals -> DepResolverParams -> DepResolverParams
setIndependentGoals IndependentGoals
independentGoals
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReorderGoals -> DepResolverParams -> DepResolverParams
setReorderGoals ReorderGoals
reorderGoals
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CountConflicts -> DepResolverParams -> DepResolverParams
setCountConflicts CountConflicts
countConflicts
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FineGrainedConflicts -> DepResolverParams -> DepResolverParams
setFineGrainedConflicts FineGrainedConflicts
fineGrainedConflicts
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinimizeConflictSet -> DepResolverParams -> DepResolverParams
setMinimizeConflictSet MinimizeConflictSet
minimizeConflictSet
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AvoidReinstalls -> DepResolverParams -> DepResolverParams
setAvoidReinstalls AvoidReinstalls
avoidReinstalls
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShadowPkgs -> DepResolverParams -> DepResolverParams
setShadowPkgs ShadowPkgs
shadowPkgs
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrongFlags -> DepResolverParams -> DepResolverParams
setStrongFlags StrongFlags
strongFlags
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowBootLibInstalls -> DepResolverParams -> DepResolverParams
setAllowBootLibInstalls AllowBootLibInstalls
allowBootLibInstalls
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlyConstrained -> DepResolverParams -> DepResolverParams
setOnlyConstrained OnlyConstrained
onlyConstrained
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> DepResolverParams -> DepResolverParams
setSolverVerbosity Verbosity
verbosity
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackagesPreferenceDefault -> DepResolverParams -> DepResolverParams
setPreferenceDefault (if Bool
upgradeDeps then PackagesPreferenceDefault
PreferAllLatest
else PackagesPreferenceDefault
PreferLatestForSelected)
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowOlder -> DepResolverParams -> DepResolverParams
removeLowerBounds AllowOlder
allowOlder
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowNewer -> DepResolverParams -> DepResolverParams
removeUpperBounds AllowNewer
allowNewer
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackagePreference] -> DepResolverParams -> DepResolverParams
addPreferences
[ PackageName -> VersionRange -> PackagePreference
PackageVersionPreference PackageName
name VersionRange
ver
| PackageVersionConstraint PackageName
name VersionRange
ver <- ConfigExFlags -> [PackageVersionConstraint]
configPreferences ConfigExFlags
configExFlags ]
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
[ PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint (UserConstraint -> PackageConstraint
userToPackageConstraint UserConstraint
pc) ConstraintSource
src
| (UserConstraint
pc, ConstraintSource
src) <- ConfigExFlags -> [(UserConstraint, ConstraintSource)]
configExConstraints ConfigExFlags
configExFlags ]
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
[ let pc :: PackageConstraint
pc = ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint
(PackageName -> ConstraintScope
scopeToplevel (PackageName -> ConstraintScope) -> PackageName -> ConstraintScope
forall a b. (a -> b) -> a -> b
$ PackageSpecifier UnresolvedSourcePackage -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget PackageSpecifier UnresolvedSourcePackage
pkgSpecifier)
(FlagAssignment -> PackageProperty
PackagePropertyFlags FlagAssignment
flags)
in PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint PackageConstraint
pc ConstraintSource
ConstraintSourceConfigFlagOrTarget
| let flags :: FlagAssignment
flags = ConfigFlags -> FlagAssignment
configConfigurationsFlags ConfigFlags
configFlags
, Bool -> Bool
not (FlagAssignment -> Bool
nullFlagAssignment FlagAssignment
flags)
, PackageSpecifier UnresolvedSourcePackage
pkgSpecifier <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers ]
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
[ let pc :: PackageConstraint
pc = ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint
(PackageName -> ConstraintScope
scopeToplevel (PackageName -> ConstraintScope) -> PackageName -> ConstraintScope
forall a b. (a -> b) -> a -> b
$ PackageSpecifier UnresolvedSourcePackage -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget PackageSpecifier UnresolvedSourcePackage
pkgSpecifier)
([OptionalStanza] -> PackageProperty
PackagePropertyStanzas [OptionalStanza]
stanzas)
in PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint PackageConstraint
pc ConstraintSource
ConstraintSourceConfigFlagOrTarget
| PackageSpecifier UnresolvedSourcePackage
pkgSpecifier <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers ]
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
reinstall then DepResolverParams -> DepResolverParams
reinstallTargets else DepResolverParams -> DepResolverParams
forall a. a -> a
id)
(DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolveExecutables -> DepResolverParams -> DepResolverParams
setSolveExecutables (Bool -> SolveExecutables
SolveExecutables Bool
False)
(DepResolverParams -> DepResolverParams)
-> DepResolverParams -> DepResolverParams
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
standardInstallPolicy
InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
stanzas :: [OptionalStanza]
stanzas = [ OptionalStanza
TestStanzas | Bool
testsEnabled ]
[OptionalStanza] -> [OptionalStanza] -> [OptionalStanza]
forall a. [a] -> [a] -> [a]
++ [ OptionalStanza
BenchStanzas | Bool
benchmarksEnabled ]
testsEnabled :: Bool
testsEnabled = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags
benchmarksEnabled :: Bool
benchmarksEnabled = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags
reinstall :: Bool
reinstall = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installOverrideReinstall InstallFlags
installFlags) Bool -> Bool -> Bool
||
Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installReinstall InstallFlags
installFlags)
reorderGoals :: ReorderGoals
reorderGoals = Flag ReorderGoals -> ReorderGoals
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ReorderGoals
installReorderGoals InstallFlags
installFlags)
countConflicts :: CountConflicts
countConflicts = Flag CountConflicts -> CountConflicts
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag CountConflicts
installCountConflicts InstallFlags
installFlags)
fineGrainedConflicts :: FineGrainedConflicts
fineGrainedConflicts = Flag FineGrainedConflicts -> FineGrainedConflicts
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag FineGrainedConflicts
installFineGrainedConflicts InstallFlags
installFlags)
minimizeConflictSet :: MinimizeConflictSet
minimizeConflictSet = Flag MinimizeConflictSet -> MinimizeConflictSet
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag MinimizeConflictSet
installMinimizeConflictSet InstallFlags
installFlags)
independentGoals :: IndependentGoals
independentGoals = Flag IndependentGoals -> IndependentGoals
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag IndependentGoals
installIndependentGoals InstallFlags
installFlags)
avoidReinstalls :: AvoidReinstalls
avoidReinstalls = Flag AvoidReinstalls -> AvoidReinstalls
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag AvoidReinstalls
installAvoidReinstalls InstallFlags
installFlags)
shadowPkgs :: ShadowPkgs
shadowPkgs = Flag ShadowPkgs -> ShadowPkgs
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ShadowPkgs
installShadowPkgs InstallFlags
installFlags)
strongFlags :: StrongFlags
strongFlags = Flag StrongFlags -> StrongFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag StrongFlags
installStrongFlags InstallFlags
installFlags)
maxBackjumps :: Int
maxBackjumps = Flag Int -> Int
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Int
installMaxBackjumps InstallFlags
installFlags)
allowBootLibInstalls :: AllowBootLibInstalls
allowBootLibInstalls = Flag AllowBootLibInstalls -> AllowBootLibInstalls
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag AllowBootLibInstalls
installAllowBootLibInstalls InstallFlags
installFlags)
onlyConstrained :: OnlyConstrained
onlyConstrained = Flag OnlyConstrained -> OnlyConstrained
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag OnlyConstrained
installOnlyConstrained InstallFlags
installFlags)
upgradeDeps :: Bool
upgradeDeps = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installUpgradeDeps InstallFlags
installFlags)
onlyDeps :: Bool
onlyDeps = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installOnlyDeps InstallFlags
installFlags)
allowOlder :: AllowOlder
allowOlder = AllowOlder -> Maybe AllowOlder -> AllowOlder
forall a. a -> Maybe a -> a
fromMaybe (RelaxDeps -> AllowOlder
AllowOlder RelaxDeps
forall a. Monoid a => a
mempty)
(ConfigExFlags -> Maybe AllowOlder
configAllowOlder ConfigExFlags
configExFlags)
allowNewer :: AllowNewer
allowNewer = AllowNewer -> Maybe AllowNewer -> AllowNewer
forall a. a -> Maybe a -> a
fromMaybe (RelaxDeps -> AllowNewer
AllowNewer RelaxDeps
forall a. Monoid a => a
mempty)
(ConfigExFlags -> Maybe AllowNewer
configAllowNewer ConfigExFlags
configExFlags)
pruneInstallPlan :: Package targetpkg
=> [PackageSpecifier targetpkg]
-> SolverInstallPlan
-> Progress String String SolverInstallPlan
pruneInstallPlan :: [PackageSpecifier targetpkg]
-> SolverInstallPlan -> Progress String String SolverInstallPlan
pruneInstallPlan [PackageSpecifier targetpkg]
pkgSpecifiers =
([SolverPlanProblem] -> Progress String String SolverInstallPlan)
-> (SolverInstallPlan -> Progress String String SolverInstallPlan)
-> Either [SolverPlanProblem] SolverInstallPlan
-> Progress String String SolverInstallPlan
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Progress String String SolverInstallPlan
forall step fail done. fail -> Progress step fail done
Fail (String -> Progress String String SolverInstallPlan)
-> ([SolverPlanProblem] -> String)
-> [SolverPlanProblem]
-> Progress String String SolverInstallPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SolverPlanProblem] -> String
explain) SolverInstallPlan -> Progress String String SolverInstallPlan
forall step fail done. done -> Progress step fail done
Done
(Either [SolverPlanProblem] SolverInstallPlan
-> Progress String String SolverInstallPlan)
-> (SolverInstallPlan
-> Either [SolverPlanProblem] SolverInstallPlan)
-> SolverInstallPlan
-> Progress String String SolverInstallPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SolverPlanPackage -> Bool)
-> SolverInstallPlan
-> Either [SolverPlanProblem] SolverInstallPlan
SolverInstallPlan.remove (\SolverPlanPackage
pkg -> SolverPlanPackage -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName SolverPlanPackage
pkg PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
targetnames)
where
explain :: [SolverInstallPlan.SolverPlanProblem] -> String
explain :: [SolverPlanProblem] -> String
explain [SolverPlanProblem]
problems =
String
"Cannot select only the dependencies (as requested by the "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'--only-dependencies' flag), "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (case [PackageIdentifier]
pkgids of
[PackageIdentifier
pkgid] -> String
"the package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is "
[PackageIdentifier]
_ -> String
"the packages "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow [PackageIdentifier]
pkgids) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" are ")
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"required by a dependency of one of the other targets."
where
pkgids :: [PackageIdentifier]
pkgids =
[PackageIdentifier] -> [PackageIdentifier]
forall a. Eq a => [a] -> [a]
nub [ PackageIdentifier
depid
| SolverInstallPlan.PackageMissingDeps SolverPlanPackage
_ [PackageIdentifier]
depids <- [SolverPlanProblem]
problems
, PackageIdentifier
depid <- [PackageIdentifier]
depids
, PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
depid PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
targetnames ]
targetnames :: [PackageName]
targetnames = (PackageSpecifier targetpkg -> PackageName)
-> [PackageSpecifier targetpkg] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier targetpkg -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget [PackageSpecifier targetpkg]
pkgSpecifiers
checkPrintPlan :: Verbosity
-> InstalledPackageIndex
-> InstallPlan
-> SourcePackageDb
-> InstallFlags
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO ()
checkPrintPlan :: Verbosity
-> InstalledPackageIndex
-> InstallPlan
-> SourcePackageDb
-> InstallFlags
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO ()
checkPrintPlan Verbosity
verbosity InstalledPackageIndex
installed InstallPlan
installPlan SourcePackageDb
sourcePkgDb
InstallFlags
installFlags [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers = do
let preExistingTargets :: [InstalledPackageInfo]
preExistingTargets =
[ InstalledPackageInfo
p | let tgts :: [PackageName]
tgts = (PackageSpecifier UnresolvedSourcePackage -> PackageName)
-> [PackageSpecifier UnresolvedSourcePackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers,
InstallPlan.PreExisting InstalledPackageInfo
p <- InstallPlan
-> [GenericPlanPackage
InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList InstallPlan
installPlan,
InstalledPackageInfo -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName InstalledPackageInfo
p PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
tgts ]
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nothingToInstall (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
String
"All the requested packages are already installed:"
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (InstalledPackageInfo -> String)
-> [InstalledPackageInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> String)
-> (InstalledPackageInfo -> PackageIdentifier)
-> InstalledPackageInfo
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) [InstalledPackageInfo]
preExistingTargets
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"Use --reinstall if you want to reinstall anyway."]
let lPlan :: [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
lPlan =
[ (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg, PackageStatus
status)
| GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg <- InstallPlan
-> [GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)]
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> [GenericReadyPackage srcpkg]
InstallPlan.executionOrder InstallPlan
installPlan
, let status :: PackageStatus
status = InstalledPackageIndex
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageStatus
packageStatus InstalledPackageIndex
installed GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg ]
let reinstalledPkgs :: [UnitId]
reinstalledPkgs =
[ UnitId
ipkg
| (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
_pkg, PackageStatus
status) <- [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
lPlan
, UnitId
ipkg <- PackageStatus -> [UnitId]
extractReinstalls PackageStatus
status ]
let oldBrokenPkgs :: [UnitId]
oldBrokenPkgs =
(InstalledPackageInfo -> UnitId)
-> [InstalledPackageInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> UnitId
Installed.installedUnitId
([InstalledPackageInfo] -> [UnitId])
-> (InstalledPackageIndex -> [InstalledPackageInfo])
-> InstalledPackageIndex
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageIndex -> [UnitId] -> [InstalledPackageInfo]
forall a. PackageInstalled a => PackageIndex a -> [UnitId] -> [a]
PackageIndex.reverseDependencyClosure InstalledPackageIndex
installed
([UnitId] -> [InstalledPackageInfo])
-> (InstalledPackageIndex -> [UnitId])
-> InstalledPackageIndex
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((InstalledPackageInfo, [UnitId]) -> UnitId)
-> [(InstalledPackageInfo, [UnitId])] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledPackageInfo -> UnitId
Installed.installedUnitId (InstalledPackageInfo -> UnitId)
-> ((InstalledPackageInfo, [UnitId]) -> InstalledPackageInfo)
-> (InstalledPackageInfo, [UnitId])
-> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledPackageInfo, [UnitId]) -> InstalledPackageInfo
forall a b. (a, b) -> a
fst)
([(InstalledPackageInfo, [UnitId])] -> [UnitId])
-> (InstalledPackageIndex -> [(InstalledPackageInfo, [UnitId])])
-> InstalledPackageIndex
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageIndex -> [(InstalledPackageInfo, [UnitId])]
forall a. PackageInstalled a => PackageIndex a -> [(a, [UnitId])]
PackageIndex.brokenPackages
(InstalledPackageIndex -> [UnitId])
-> InstalledPackageIndex -> [UnitId]
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
installed
let excluded :: [UnitId]
excluded = [UnitId]
reinstalledPkgs [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId]
oldBrokenPkgs
let newBrokenPkgs :: [InstalledPackageInfo]
newBrokenPkgs =
(InstalledPackageInfo -> Bool)
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ InstalledPackageInfo
p -> Bool -> Bool
not (InstalledPackageInfo -> UnitId
Installed.installedUnitId InstalledPackageInfo
p UnitId -> [UnitId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnitId]
excluded))
(InstalledPackageIndex -> [UnitId] -> [InstalledPackageInfo]
forall a. PackageInstalled a => PackageIndex a -> [UnitId] -> [a]
PackageIndex.reverseDependencyClosure InstalledPackageIndex
installed [UnitId]
reinstalledPkgs)
let containsReinstalls :: Bool
containsReinstalls = Bool -> Bool
not ([UnitId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitId]
reinstalledPkgs)
let breaksPkgs :: Bool
breaksPkgs = Bool -> Bool
not ([InstalledPackageInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstalledPackageInfo]
newBrokenPkgs)
let adaptedVerbosity :: Verbosity
adaptedVerbosity
| Bool
containsReinstalls
, Bool -> Bool
not Bool
overrideReinstall = (Verbosity -> Verbosity) -> Verbosity -> Verbosity
modifyVerbosity (Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
max Verbosity
verbose) Verbosity
verbosity
| Bool
otherwise = Verbosity
verbosity
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
dryRun Bool -> Bool -> Bool
|| Bool
containsReinstalls Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
overrideReinstall) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool
-> Verbosity
-> [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
-> SourcePackageDb
-> IO ()
printPlan (Bool
dryRun Bool -> Bool -> Bool
|| Bool
breaksPkgs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
overrideReinstall)
Verbosity
adaptedVerbosity [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
lPlan SourcePackageDb
sourcePkgDb
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
containsReinstalls (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
if Bool
breaksPkgs
then do
(if Bool
dryRun Bool -> Bool -> Bool
|| Bool
overrideReinstall then Verbosity -> String -> IO ()
warn else 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
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
String
"The following packages are likely to be broken by the reinstalls:"
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (InstalledPackageInfo -> String)
-> [InstalledPackageInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (MungedPackageId -> String
forall a. Pretty a => a -> String
prettyShow (MungedPackageId -> String)
-> (InstalledPackageInfo -> MungedPackageId)
-> InstalledPackageInfo
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId) [InstalledPackageInfo]
newBrokenPkgs
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ if Bool
overrideReinstall
then if Bool
dryRun then [] else
[String
"Continuing even though " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"the plan contains dangerous reinstalls."]
else
[String
"Use --force-reinstalls if you want to install anyway."]
else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dryRun (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
warn Verbosity
verbosity
String
"Note that reinstalls are always dangerous. Continuing anyway..."
let offline :: Bool
offline = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InstallFlags -> Flag Bool
installOfflineMode InstallFlags
installFlags)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
offline (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let pkgs :: [UnresolvedSourcePackage]
pkgs = [ ConfiguredPackage UnresolvedPkgLoc -> UnresolvedSourcePackage
forall loc. ConfiguredPackage loc -> SourcePackage loc
confPkgSource ConfiguredPackage UnresolvedPkgLoc
cpkg
| InstallPlan.Configured ConfiguredPackage UnresolvedPkgLoc
cpkg <- InstallPlan
-> [GenericPlanPackage
InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList InstallPlan
installPlan ]
[PackageIdentifier]
notFetched <- ([UnresolvedSourcePackage] -> [PackageIdentifier])
-> IO [UnresolvedSourcePackage] -> IO [PackageIdentifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((UnresolvedSourcePackage -> PackageIdentifier)
-> [UnresolvedSourcePackage] -> [PackageIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map UnresolvedSourcePackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId)
(IO [UnresolvedSourcePackage] -> IO [PackageIdentifier])
-> ([UnresolvedSourcePackage] -> IO [UnresolvedSourcePackage])
-> [UnresolvedSourcePackage]
-> IO [PackageIdentifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnresolvedSourcePackage -> IO Bool)
-> [UnresolvedSourcePackage] -> IO [UnresolvedSourcePackage]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Maybe ResolvedPkgLoc -> Bool)
-> IO (Maybe ResolvedPkgLoc) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ResolvedPkgLoc -> Bool
forall a. Maybe a -> Bool
isNothing (IO (Maybe ResolvedPkgLoc) -> IO Bool)
-> (UnresolvedSourcePackage -> IO (Maybe ResolvedPkgLoc))
-> UnresolvedSourcePackage
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
checkFetched (UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc))
-> (UnresolvedSourcePackage -> UnresolvedPkgLoc)
-> UnresolvedSourcePackage
-> IO (Maybe ResolvedPkgLoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedSourcePackage -> UnresolvedPkgLoc
forall loc. SourcePackage loc -> loc
srcpkgSource)
([UnresolvedSourcePackage] -> IO [PackageIdentifier])
-> [UnresolvedSourcePackage] -> IO [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ [UnresolvedSourcePackage]
pkgs
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageIdentifier] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageIdentifier]
notFetched) (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
"Can't download packages in offline mode. "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Must download the following packages to proceed:\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow [PackageIdentifier]
notFetched)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nTry using 'cabal fetch'."
where
nothingToInstall :: Bool
nothingToInstall = [GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (([GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)],
Processing)
-> [GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)]
forall a b. (a, b) -> a
fst (InstallPlan
-> ([GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)],
Processing)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
InstallPlan.ready InstallPlan
installPlan))
dryRun :: Bool
dryRun = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDryRun InstallFlags
installFlags)
overrideReinstall :: Bool
overrideReinstall = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installOverrideReinstall InstallFlags
installFlags)
data PackageStatus = NewPackage
| NewVersion [Version]
| Reinstall [UnitId] [PackageChange]
type PackageChange = MergeResult MungedPackageId MungedPackageId
extractReinstalls :: PackageStatus -> [UnitId]
(Reinstall [UnitId]
ipids [PackageChange]
_) = [UnitId]
ipids
extractReinstalls PackageStatus
_ = []
packageStatus :: InstalledPackageIndex
-> ReadyPackage
-> PackageStatus
packageStatus :: InstalledPackageIndex
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageStatus
packageStatus InstalledPackageIndex
installedPkgIndex GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
cpkg =
case InstalledPackageIndex
-> PackageName -> [(Version, [InstalledPackageInfo])]
forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PackageIndex.lookupPackageName InstalledPackageIndex
installedPkgIndex
(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
cpkg) of
[] -> PackageStatus
NewPackage
[(Version, [InstalledPackageInfo])]
ps -> case (InstalledPackageInfo -> Bool)
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((MungedPackageId -> MungedPackageId -> Bool
forall a. Eq a => a -> a -> Bool
== GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
cpkg)
(MungedPackageId -> Bool)
-> (InstalledPackageInfo -> MungedPackageId)
-> InstalledPackageInfo
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId) (((Version, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> [(Version, [InstalledPackageInfo])] -> [InstalledPackageInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Version, [InstalledPackageInfo]) -> [InstalledPackageInfo]
forall a b. (a, b) -> b
snd [(Version, [InstalledPackageInfo])]
ps) of
[] -> [Version] -> PackageStatus
NewVersion (((Version, [InstalledPackageInfo]) -> Version)
-> [(Version, [InstalledPackageInfo])] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map (Version, [InstalledPackageInfo]) -> Version
forall a b. (a, b) -> a
fst [(Version, [InstalledPackageInfo])]
ps)
pkgs :: [InstalledPackageInfo]
pkgs@(InstalledPackageInfo
pkg:[InstalledPackageInfo]
_) -> [UnitId] -> [PackageChange] -> PackageStatus
Reinstall ((InstalledPackageInfo -> UnitId)
-> [InstalledPackageInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> UnitId
Installed.installedUnitId [InstalledPackageInfo]
pkgs)
(InstalledPackageInfo
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> [PackageChange]
changes InstalledPackageInfo
pkg GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
cpkg)
where
changes :: Installed.InstalledPackageInfo
-> ReadyPackage
-> [PackageChange]
changes :: InstalledPackageInfo
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> [PackageChange]
changes InstalledPackageInfo
pkg (ReadyPackage ConfiguredPackage UnresolvedPkgLoc
pkg') = (PackageChange -> Bool) -> [PackageChange] -> [PackageChange]
forall a. (a -> Bool) -> [a] -> [a]
filter PackageChange -> Bool
forall a. Eq a => MergeResult a a -> Bool
changed ([PackageChange] -> [PackageChange])
-> [PackageChange] -> [PackageChange]
forall a b. (a -> b) -> a -> b
$
(MungedPackageId -> MungedPackageId -> Ordering)
-> [MungedPackageId] -> [MungedPackageId] -> [PackageChange]
forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy ((MungedPackageId -> MungedPackageName)
-> MungedPackageId -> MungedPackageId -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing MungedPackageId -> MungedPackageName
mungedName)
([UnitId] -> [MungedPackageId]
resolveInstalledIds ([UnitId] -> [MungedPackageId]) -> [UnitId] -> [MungedPackageId]
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> [UnitId]
Installed.depends InstalledPackageInfo
pkg)
([UnitId] -> [MungedPackageId]
resolveInstalledIds ([UnitId] -> [MungedPackageId]) -> [UnitId] -> [MungedPackageId]
forall a b. (a -> b) -> a -> b
$ ComponentDeps [UnitId] -> [UnitId]
forall a. Monoid a => ComponentDeps a -> a
CD.nonSetupDeps (ConfiguredPackage UnresolvedPkgLoc -> ComponentDeps [UnitId]
forall pkg. PackageFixedDeps pkg => pkg -> ComponentDeps [UnitId]
depends ConfiguredPackage UnresolvedPkgLoc
pkg'))
resolveInstalledIds :: [UnitId] -> [MungedPackageId]
resolveInstalledIds :: [UnitId] -> [MungedPackageId]
resolveInstalledIds =
[MungedPackageId] -> [MungedPackageId]
forall a. Eq a => [a] -> [a]
nub
([MungedPackageId] -> [MungedPackageId])
-> ([UnitId] -> [MungedPackageId]) -> [UnitId] -> [MungedPackageId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MungedPackageId] -> [MungedPackageId]
forall a. Ord a => [a] -> [a]
sort
([MungedPackageId] -> [MungedPackageId])
-> ([UnitId] -> [MungedPackageId]) -> [UnitId] -> [MungedPackageId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledPackageInfo -> MungedPackageId)
-> [InstalledPackageInfo] -> [MungedPackageId]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId
([InstalledPackageInfo] -> [MungedPackageId])
-> ([UnitId] -> [InstalledPackageInfo])
-> [UnitId]
-> [MungedPackageId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId -> Maybe InstalledPackageInfo)
-> [UnitId] -> [InstalledPackageInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (InstalledPackageIndex -> UnitId -> Maybe InstalledPackageInfo
forall a. PackageIndex a -> UnitId -> Maybe a
PackageIndex.lookupUnitId InstalledPackageIndex
installedPkgIndex)
changed :: MergeResult a a -> Bool
changed (InBoth a
pkgid a
pkgid') = a
pkgid a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
pkgid'
changed MergeResult a a
_ = Bool
True
printPlan :: Bool
-> Verbosity
-> [(ReadyPackage, PackageStatus)]
-> SourcePackageDb
-> IO ()
printPlan :: Bool
-> Verbosity
-> [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
-> SourcePackageDb
-> IO ()
printPlan Bool
dryRun Verbosity
verbosity [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
plan SourcePackageDb
sourcePkgDb = case [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
plan of
[] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
pkgs
| Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Verbosity.verbose -> Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
(String
"In order, the following " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wouldWill String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" be installed:")
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)
-> String)
-> [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
-> [String]
forall a b. (a -> b) -> [a] -> [b]
map (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)
-> String
forall loc.
(GenericReadyPackage (ConfiguredPackage loc), PackageStatus)
-> String
showPkgAndReason [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
pkgs
| Bool
otherwise -> Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
(String
"In order, the following " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wouldWill
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" be installed (use -v for more details):")
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)
-> String)
-> [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
-> [String]
forall a b. (a -> b) -> [a] -> [b]
map (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)
-> String
forall srcpkg b. Package srcpkg => (srcpkg, b) -> String
showPkg [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
pkgs
where
wouldWill :: String
wouldWill | Bool
dryRun = String
"would"
| Bool
otherwise = String
"will"
showPkg :: (srcpkg, b) -> String
showPkg (srcpkg
pkg, b
_) = PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (srcpkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId srcpkg
pkg) String -> String -> String
forall a. [a] -> [a] -> [a]
++
srcpkg -> String
forall srcpkg. Package srcpkg => srcpkg -> String
showLatest (srcpkg
pkg)
showPkgAndReason :: (GenericReadyPackage (ConfiguredPackage loc), PackageStatus)
-> String
showPkgAndReason (ReadyPackage ConfiguredPackage loc
pkg', PackageStatus
pr) = [String] -> String
unwords
[ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (ConfiguredPackage loc -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ConfiguredPackage loc
pkg')
, ConfiguredPackage loc -> String
forall srcpkg. Package srcpkg => srcpkg -> String
showLatest ConfiguredPackage loc
pkg'
, FlagAssignment -> String
showFlagAssignment (ConfiguredPackage loc -> FlagAssignment
forall loc. ConfiguredPackage loc -> FlagAssignment
nonDefaultFlags ConfiguredPackage loc
pkg')
, OptionalStanzaSet -> String
showStanzas (ConfiguredPackage loc -> OptionalStanzaSet
forall loc. ConfiguredPackage loc -> OptionalStanzaSet
confPkgStanzas ConfiguredPackage loc
pkg')
, ConfiguredPackage loc -> String
forall srcpkg. Package srcpkg => srcpkg -> String
showDep ConfiguredPackage loc
pkg'
, case PackageStatus
pr of
PackageStatus
NewPackage -> String
"(new package)"
NewVersion [Version]
_ -> String
"(new version)"
Reinstall [UnitId]
_ [PackageChange]
cs -> String
"(reinstall)" String -> String -> String
forall a. [a] -> [a] -> [a]
++ case [PackageChange]
cs of
[] -> String
""
[PackageChange]
diff -> String
"(changes: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((PackageChange -> String) -> [PackageChange] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageChange -> String
forall a. Pretty a => MergeResult a MungedPackageId -> String
change [PackageChange]
diff)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
]
showLatest :: Package srcpkg => srcpkg -> String
showLatest :: srcpkg -> String
showLatest srcpkg
pkg = case Maybe Version
mLatestVersion of
Just Version
latestVersion ->
if srcpkg -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion srcpkg
pkg Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
latestVersion
then (String
"(latest: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
latestVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
else String
""
Maybe Version
Nothing -> String
""
where
mLatestVersion :: Maybe Version
mLatestVersion :: Maybe Version
mLatestVersion = (UnresolvedSourcePackage -> Version)
-> Maybe UnresolvedSourcePackage -> Maybe Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnresolvedSourcePackage -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion (Maybe UnresolvedSourcePackage -> Maybe Version)
-> Maybe UnresolvedSourcePackage -> Maybe Version
forall a b. (a -> b) -> a -> b
$
[UnresolvedSourcePackage] -> Maybe UnresolvedSourcePackage
forall a. [a] -> Maybe a
safeLast ([UnresolvedSourcePackage] -> Maybe UnresolvedSourcePackage)
-> [UnresolvedSourcePackage] -> Maybe UnresolvedSourcePackage
forall a b. (a -> b) -> a -> b
$
PackageIndex UnresolvedSourcePackage
-> PackageName -> [UnresolvedSourcePackage]
forall pkg. Package pkg => PackageIndex pkg -> PackageName -> [pkg]
SourcePackageIndex.lookupPackageName
(SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
sourcePkgDb)
(srcpkg -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName srcpkg
pkg)
toFlagAssignment :: [PackageFlag] -> FlagAssignment
toFlagAssignment :: [PackageFlag] -> FlagAssignment
toFlagAssignment = [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment ([(FlagName, Bool)] -> FlagAssignment)
-> ([PackageFlag] -> [(FlagName, Bool)])
-> [PackageFlag]
-> FlagAssignment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageFlag -> (FlagName, Bool))
-> [PackageFlag] -> [(FlagName, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\ PackageFlag
f -> (PackageFlag -> FlagName
flagName PackageFlag
f, PackageFlag -> Bool
flagDefault PackageFlag
f))
nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment
nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment
nonDefaultFlags ConfiguredPackage loc
cpkg =
let defaultAssignment :: FlagAssignment
defaultAssignment =
[PackageFlag] -> FlagAssignment
toFlagAssignment
(GenericPackageDescription -> [PackageFlag]
genPackageFlags (SourcePackage loc -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
SourcePackage.srcpkgDescription (SourcePackage loc -> GenericPackageDescription)
-> SourcePackage loc -> GenericPackageDescription
forall a b. (a -> b) -> a -> b
$
ConfiguredPackage loc -> SourcePackage loc
forall loc. ConfiguredPackage loc -> SourcePackage loc
confPkgSource ConfiguredPackage loc
cpkg))
in ConfiguredPackage loc -> FlagAssignment
forall loc. ConfiguredPackage loc -> FlagAssignment
confPkgFlags ConfiguredPackage loc
cpkg FlagAssignment -> FlagAssignment -> FlagAssignment
`diffFlagAssignment` FlagAssignment
defaultAssignment
change :: MergeResult a MungedPackageId -> String
change (OnlyInLeft a
pkgid) = a -> String
forall a. Pretty a => a -> String
prettyShow a
pkgid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" removed"
change (InBoth a
pkgid MungedPackageId
pkgid') = a -> String
forall a. Pretty a => a -> String
prettyShow a
pkgid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow (MungedPackageId -> Version
mungedVersion MungedPackageId
pkgid')
change (OnlyInRight MungedPackageId
pkgid') = MungedPackageId -> String
forall a. Pretty a => a -> String
prettyShow MungedPackageId
pkgid' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" added"
showDep :: pkg -> String
showDep pkg
pkg | Just [PackageIdentifier]
rdeps <- PackageIdentifier
-> Map PackageIdentifier [PackageIdentifier]
-> Maybe [PackageIdentifier]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (pkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg) Map PackageIdentifier [PackageIdentifier]
revDeps
= String
" (via: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow [PackageIdentifier]
rdeps) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
| Bool
otherwise = String
""
revDepGraphEdges :: [(PackageId, PackageId)]
revDepGraphEdges :: [(PackageIdentifier, PackageIdentifier)]
revDepGraphEdges = [ (PackageIdentifier
rpid, ConfiguredPackage UnresolvedPkgLoc -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ConfiguredPackage UnresolvedPkgLoc
cpkg)
| (ReadyPackage ConfiguredPackage UnresolvedPkgLoc
cpkg, PackageStatus
_) <- [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
plan
, ConfiguredId
PackageIdentifier
rpid
(Just
(PackageDescription.CLibName
LibraryName
PackageDescription.LMainLibName))
ComponentId
_
<- ComponentDeps [ConfiguredId] -> [ConfiguredId]
forall a. Monoid a => ComponentDeps a -> a
CD.flatDeps (ConfiguredPackage UnresolvedPkgLoc -> ComponentDeps [ConfiguredId]
forall loc. ConfiguredPackage loc -> ComponentDeps [ConfiguredId]
confPkgDeps ConfiguredPackage UnresolvedPkgLoc
cpkg) ]
revDeps :: Map.Map PackageId [PackageId]
revDeps :: Map PackageIdentifier [PackageIdentifier]
revDeps = ([PackageIdentifier] -> [PackageIdentifier] -> [PackageIdentifier])
-> [(PackageIdentifier, [PackageIdentifier])]
-> Map PackageIdentifier [PackageIdentifier]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [PackageIdentifier] -> [PackageIdentifier] -> [PackageIdentifier]
forall a. [a] -> [a] -> [a]
(++) (((PackageIdentifier, PackageIdentifier)
-> (PackageIdentifier, [PackageIdentifier]))
-> [(PackageIdentifier, PackageIdentifier)]
-> [(PackageIdentifier, [PackageIdentifier])]
forall a b. (a -> b) -> [a] -> [b]
map ((PackageIdentifier -> [PackageIdentifier])
-> (PackageIdentifier, PackageIdentifier)
-> (PackageIdentifier, [PackageIdentifier])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageIdentifier -> [PackageIdentifier] -> [PackageIdentifier]
forall a. a -> [a] -> [a]
:[])) [(PackageIdentifier, PackageIdentifier)]
revDepGraphEdges)
reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String
-> IO ()
reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String -> IO ()
reportPlanningFailure Verbosity
verbosity
(PackageDBStack
_, RepoContext
_, Compiler
comp, Platform
platform, ProgramDb
_
,GlobalFlags
_, ConfigFlags
configFlags, ConfigExFlags
_, InstallFlags
installFlags, HaddockFlags
_, TestFlags
_, BenchmarkFlags
_)
(InstalledPackageIndex
_, SourcePackageDb
sourcePkgDb, PkgConfigDb
_, [UserTarget]
_, [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers, HttpTransport
_)
String
message = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
reportFailure (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let pkgids :: [PackageIdentifier]
pkgids = (PackageIdentifier -> Bool)
-> [PackageIdentifier] -> [PackageIdentifier]
forall a. (a -> Bool) -> [a] -> [a]
filter
(PackageIndex UnresolvedSourcePackage -> PackageIdentifier -> Bool
forall pkg.
Package pkg =>
PackageIndex pkg -> PackageIdentifier -> Bool
SourcePackageIndex.elemByPackageId (SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
sourcePkgDb)) ([PackageIdentifier] -> [PackageIdentifier])
-> [PackageIdentifier] -> [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$
(PackageSpecifier UnresolvedSourcePackage
-> Maybe PackageIdentifier)
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageIdentifier]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageSpecifier UnresolvedSourcePackage -> Maybe PackageIdentifier
forall pkg.
Package pkg =>
PackageSpecifier pkg -> Maybe PackageIdentifier
theSpecifiedPackage [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
buildReports :: [(BuildReport, Maybe Repo)]
buildReports = Platform
-> CompilerId
-> [PackageIdentifier]
-> FlagAssignment
-> [(BuildReport, Maybe Repo)]
BuildReports.fromPlanningFailure Platform
platform
(Compiler -> CompilerId
compilerId Compiler
comp) [PackageIdentifier]
pkgids
(ConfigFlags -> FlagAssignment
configConfigurationsFlags ConfigFlags
configFlags)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(BuildReport, Maybe Repo)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(BuildReport, Maybe Repo)]
buildReports) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Solver failure will be reported for "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow [PackageIdentifier]
pkgids)
CompilerInfo
-> [PathTemplate]
-> [(BuildReport, Maybe Repo)]
-> Platform
-> IO ()
BuildReports.storeLocal (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
(NubList PathTemplate -> [PathTemplate]
forall a. NubList a -> [a]
fromNubList (NubList PathTemplate -> [PathTemplate])
-> NubList PathTemplate -> [PathTemplate]
forall a b. (a -> b) -> a -> b
$ InstallFlags -> NubList PathTemplate
installSummaryFile InstallFlags
installFlags)
[(BuildReport, Maybe Repo)]
buildReports Platform
platform
case Maybe PathTemplate
logFile of
Maybe PathTemplate
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PathTemplate
template -> [PackageIdentifier] -> (PackageIdentifier -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PackageIdentifier]
pkgids ((PackageIdentifier -> IO ()) -> IO ())
-> (PackageIdentifier -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PackageIdentifier
pkgid ->
let env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv PackageIdentifier
pkgid UnitId
forall a. a
dummyIpid
(Compiler -> CompilerInfo
compilerInfo Compiler
comp) Platform
platform
path :: String
path = PathTemplate -> String
fromPathTemplate (PathTemplate -> String) -> PathTemplate -> String
forall a b. (a -> b) -> a -> b
$ PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env PathTemplate
template
in String -> String -> IO ()
writeFile String
path String
message
where
reportFailure :: Bool
reportFailure = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installReportPlanningFailure InstallFlags
installFlags)
logFile :: Maybe PathTemplate
logFile = Flag PathTemplate -> Maybe PathTemplate
forall a. Flag a -> Maybe a
flagToMaybe (InstallFlags -> Flag PathTemplate
installLogFile InstallFlags
installFlags)
dummyIpid :: a
dummyIpid = String -> a
forall a. HasCallStack => String -> a
error String
"reportPlanningFailure: installed package ID not available"
theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId
theSpecifiedPackage :: PackageSpecifier pkg -> Maybe PackageIdentifier
theSpecifiedPackage PackageSpecifier pkg
pkgSpec =
case PackageSpecifier pkg
pkgSpec of
NamedPackage PackageName
name [PackagePropertyVersion VersionRange
version]
-> PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name (Version -> PackageIdentifier)
-> Maybe Version -> Maybe PackageIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VersionRange -> Maybe Version
trivialRange VersionRange
version
NamedPackage PackageName
_ [PackageProperty]
_ -> Maybe PackageIdentifier
forall a. Maybe a
Nothing
SpecificSourcePackage pkg
pkg -> PackageIdentifier -> Maybe PackageIdentifier
forall a. a -> Maybe a
Just (PackageIdentifier -> Maybe PackageIdentifier)
-> PackageIdentifier -> Maybe PackageIdentifier
forall a b. (a -> b) -> a -> b
$ pkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg
where
trivialRange :: VersionRange -> Maybe Version
trivialRange :: VersionRange -> Maybe Version
trivialRange = Maybe Version
-> (Version -> Maybe Version)
-> (Version -> Maybe Version)
-> (Version -> Maybe Version)
-> (Maybe Version -> Maybe Version -> Maybe Version)
-> (Maybe Version -> Maybe Version -> Maybe Version)
-> VersionRange
-> Maybe Version
forall a.
a
-> (Version -> a)
-> (Version -> a)
-> (Version -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> VersionRange
-> a
foldVersionRange
Maybe Version
forall a. Maybe a
Nothing
Version -> Maybe Version
forall a. a -> Maybe a
Just
(\Version
_ -> Maybe Version
forall a. Maybe a
Nothing)
(\Version
_ -> Maybe Version
forall a. Maybe a
Nothing)
(\Maybe Version
_ Maybe Version
_ -> Maybe Version
forall a. Maybe a
Nothing)
(\Maybe Version
_ Maybe Version
_ -> Maybe Version
forall a. Maybe a
Nothing)
postInstallActions :: Verbosity
-> InstallArgs
-> [UserTarget]
-> InstallPlan
-> BuildOutcomes
-> IO ()
postInstallActions :: Verbosity
-> InstallArgs
-> [UserTarget]
-> InstallPlan
-> BuildOutcomes
-> IO ()
postInstallActions Verbosity
verbosity
(PackageDBStack
packageDBs, RepoContext
_, Compiler
comp, Platform
platform, ProgramDb
progdb
,GlobalFlags
globalFlags, ConfigFlags
configFlags, ConfigExFlags
_, InstallFlags
installFlags, HaddockFlags
_, TestFlags
_, BenchmarkFlags
_)
[UserTarget]
_ InstallPlan
installPlan BuildOutcomes
buildOutcomes = do
let buildReports :: [(BuildReport, Maybe Repo)]
buildReports = Platform
-> CompilerId
-> InstallPlan
-> BuildOutcomes
-> [(BuildReport, Maybe Repo)]
BuildReports.fromInstallPlan Platform
platform (Compiler -> CompilerId
compilerId Compiler
comp)
InstallPlan
installPlan BuildOutcomes
buildOutcomes
CompilerInfo
-> [PathTemplate]
-> [(BuildReport, Maybe Repo)]
-> Platform
-> IO ()
BuildReports.storeLocal (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
(NubList PathTemplate -> [PathTemplate]
forall a. NubList a -> [a]
fromNubList (NubList PathTemplate -> [PathTemplate])
-> NubList PathTemplate -> [PathTemplate]
forall a b. (a -> b) -> a -> b
$ InstallFlags -> NubList PathTemplate
installSummaryFile InstallFlags
installFlags)
[(BuildReport, Maybe Repo)]
buildReports
Platform
platform
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportLevel
reportingLevel ReportLevel -> ReportLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= ReportLevel
AnonymousReports) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[(BuildReport, Maybe Repo)] -> IO ()
BuildReports.storeAnonymous [(BuildReport, Maybe Repo)]
buildReports
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportLevel
reportingLevel ReportLevel -> ReportLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> String -> [(BuildReport, Maybe Repo)] -> IO ()
storeDetailedBuildReports Verbosity
verbosity String
logsDir [(BuildReport, Maybe Repo)]
buildReports
Verbosity
-> PackageDBStack
-> Compiler
-> Platform
-> ProgramDb
-> ConfigFlags
-> InstallFlags
-> BuildOutcomes
-> IO ()
regenerateHaddockIndex Verbosity
verbosity PackageDBStack
packageDBs Compiler
comp Platform
platform ProgramDb
progdb
ConfigFlags
configFlags InstallFlags
installFlags BuildOutcomes
buildOutcomes
Verbosity
-> Platform
-> Compiler
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> BuildOutcomes
-> IO ()
symlinkBinaries Verbosity
verbosity Platform
platform Compiler
comp ConfigFlags
configFlags InstallFlags
installFlags
InstallPlan
installPlan BuildOutcomes
buildOutcomes
Verbosity -> BuildOutcomes -> IO ()
printBuildFailures Verbosity
verbosity BuildOutcomes
buildOutcomes
where
reportingLevel :: ReportLevel
reportingLevel = Flag ReportLevel -> ReportLevel
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ReportLevel
installBuildReports InstallFlags
installFlags)
logsDir :: String
logsDir = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (GlobalFlags -> Flag String
globalLogsDir GlobalFlags
globalFlags)
storeDetailedBuildReports :: Verbosity -> FilePath
-> [(BuildReports.BuildReport, Maybe Repo)] -> IO ()
storeDetailedBuildReports :: Verbosity -> String -> [(BuildReport, Maybe Repo)] -> IO ()
storeDetailedBuildReports Verbosity
verbosity String
logsDir [(BuildReport, Maybe Repo)]
reports = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
[ do String
dotCabal <- IO String
getCabalDir
let logFileName :: String
logFileName = PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (BuildReport -> PackageIdentifier
BuildReports.package BuildReport
report) String -> String -> String
<.> String
"log"
logFile :: String
logFile = String
logsDir String -> String -> String
</> String
logFileName
reportsDir :: String
reportsDir = String
dotCabal String -> String -> String
</> String
"reports" String -> String -> String
</> RepoName -> String
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
remoteRepo)
reportFile :: String
reportFile = String
reportsDir String -> String -> String
</> String
logFileName
IO () -> IO ()
handleMissingLogFile (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String
buildLog <- String -> IO String
readFile String
logFile
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
reportsDir
String -> String -> IO ()
writeFile String
reportFile ((String, String) -> String
forall a. Show a => a -> String
show (BuildReport -> String
showBuildReport BuildReport
report, String
buildLog))
| (BuildReport
report, Just Repo
repo) <- [(BuildReport, Maybe Repo)]
reports
, Just RemoteRepo
remoteRepo <- [Repo -> Maybe RemoteRepo
maybeRepoRemote Repo
repo]
, InstallOutcome -> Bool
isLikelyToHaveLogFile (BuildReport -> InstallOutcome
BuildReports.installOutcome BuildReport
report) ]
where
isLikelyToHaveLogFile :: InstallOutcome -> Bool
isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = Bool
True
isLikelyToHaveLogFile BuildReports.BuildFailed {} = Bool
True
isLikelyToHaveLogFile BuildReports.InstallFailed {} = Bool
True
isLikelyToHaveLogFile BuildReports.InstallOk {} = Bool
True
isLikelyToHaveLogFile InstallOutcome
_ = Bool
False
handleMissingLogFile :: IO () -> IO ()
handleMissingLogFile = (IOError -> Maybe IOError) -> (IOError -> IO ()) -> IO () -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
Exception.handleJust IOError -> Maybe IOError
missingFile ((IOError -> IO ()) -> IO () -> IO ())
-> (IOError -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOError
ioe ->
Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Missing log file for build report: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (IOError -> Maybe String
ioeGetFileName IOError
ioe)
missingFile :: IOError -> Maybe IOError
missingFile IOError
ioe
| IOError -> Bool
isDoesNotExistError IOError
ioe = IOError -> Maybe IOError
forall a. a -> Maybe a
Just IOError
ioe
missingFile IOError
_ = Maybe IOError
forall a. Maybe a
Nothing
regenerateHaddockIndex :: Verbosity
-> [PackageDB]
-> Compiler
-> Platform
-> ProgramDb
-> ConfigFlags
-> InstallFlags
-> BuildOutcomes
-> IO ()
regenerateHaddockIndex :: Verbosity
-> PackageDBStack
-> Compiler
-> Platform
-> ProgramDb
-> ConfigFlags
-> InstallFlags
-> BuildOutcomes
-> IO ()
regenerateHaddockIndex Verbosity
verbosity PackageDBStack
packageDBs Compiler
comp Platform
platform ProgramDb
progdb
ConfigFlags
configFlags InstallFlags
installFlags BuildOutcomes
buildOutcomes
| Bool
haddockIndexFileIsRequested Bool -> Bool -> Bool
&& Bool
shouldRegenerateHaddockIndex = do
InstallDirTemplates
defaultDirs <- CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
InstallDirs.defaultInstallDirs
(Compiler -> CompilerFlavor
compilerFlavor Compiler
comp)
(Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags))
Bool
True
let indexFileTemplate :: PathTemplate
indexFileTemplate = Flag PathTemplate -> PathTemplate
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag PathTemplate
installHaddockIndex InstallFlags
installFlags)
indexFile :: String
indexFile = InstallDirTemplates -> PathTemplate -> String
substHaddockIndexFileName InstallDirTemplates
defaultDirs PathTemplate
indexFileTemplate
Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Updating documentation index " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
indexFile
InstalledPackageIndex
installedPkgIndex <- Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStack
packageDBs ProgramDb
progdb
Verbosity -> InstalledPackageIndex -> ProgramDb -> String -> IO ()
Haddock.regenerateHaddockIndex Verbosity
verbosity InstalledPackageIndex
installedPkgIndex ProgramDb
progdb String
indexFile
| Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
haddockIndexFileIsRequested :: Bool
haddockIndexFileIsRequested =
Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDocumentation InstallFlags
installFlags)
Bool -> Bool -> Bool
&& Maybe PathTemplate -> Bool
forall a. Maybe a -> Bool
isJust (Flag PathTemplate -> Maybe PathTemplate
forall a. Flag a -> Maybe a
flagToMaybe (InstallFlags -> Flag PathTemplate
installHaddockIndex InstallFlags
installFlags))
shouldRegenerateHaddockIndex :: Bool
shouldRegenerateHaddockIndex = Bool
normalUserInstall Bool -> Bool -> Bool
&& BuildOutcomes -> Bool
forall k a. Map k (Either a BuildResult) -> Bool
someDocsWereInstalled BuildOutcomes
buildOutcomes
where
someDocsWereInstalled :: Map k (Either a BuildResult) -> Bool
someDocsWereInstalled = (Either a BuildResult -> Bool) -> [Either a BuildResult] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either a BuildResult -> Bool
forall a. Either a BuildResult -> Bool
installedDocs ([Either a BuildResult] -> Bool)
-> (Map k (Either a BuildResult) -> [Either a BuildResult])
-> Map k (Either a BuildResult)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k (Either a BuildResult) -> [Either a BuildResult]
forall k a. Map k a -> [a]
Map.elems
installedDocs :: Either a BuildResult -> Bool
installedDocs (Right (BuildResult DocsResult
DocsOk TestsResult
_ Maybe InstalledPackageInfo
_)) = Bool
True
installedDocs Either a BuildResult
_ = Bool
False
normalUserInstall :: Bool
normalUserInstall = (PackageDB
UserPackageDB PackageDB -> PackageDBStack -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PackageDBStack
packageDBs)
Bool -> Bool -> Bool
&& (PackageDB -> Bool) -> PackageDBStack -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (PackageDB -> Bool) -> PackageDB -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDB -> Bool
isSpecificPackageDB) PackageDBStack
packageDBs
isSpecificPackageDB :: PackageDB -> Bool
isSpecificPackageDB (SpecificPackageDB String
_) = Bool
True
isSpecificPackageDB PackageDB
_ = Bool
False
substHaddockIndexFileName :: InstallDirTemplates -> PathTemplate -> String
substHaddockIndexFileName InstallDirTemplates
defaultDirs = PathTemplate -> String
fromPathTemplate
(PathTemplate -> String)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env
where
env :: PathTemplateEnv
env = PathTemplateEnv
env0 PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ InstallDirTemplates -> PathTemplateEnv
installDirsTemplateEnv InstallDirTemplates
absoluteDirs
env0 :: PathTemplateEnv
env0 = CompilerInfo -> PathTemplateEnv
InstallDirs.compilerTemplateEnv (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ Platform -> PathTemplateEnv
InstallDirs.platformTemplateEnv Platform
platform
PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ CompilerInfo -> Platform -> PathTemplateEnv
InstallDirs.abiTemplateEnv (Compiler -> CompilerInfo
compilerInfo Compiler
comp) Platform
platform
absoluteDirs :: InstallDirTemplates
absoluteDirs = PathTemplateEnv -> InstallDirTemplates -> InstallDirTemplates
InstallDirs.substituteInstallDirTemplates
PathTemplateEnv
env0 InstallDirTemplates
templateDirs
templateDirs :: InstallDirTemplates
templateDirs = (PathTemplate -> Flag PathTemplate -> PathTemplate)
-> InstallDirTemplates
-> InstallDirs (Flag PathTemplate)
-> InstallDirTemplates
forall a b c.
(a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
InstallDirs.combineInstallDirs PathTemplate -> Flag PathTemplate -> PathTemplate
forall a. a -> Flag a -> a
fromFlagOrDefault
InstallDirTemplates
defaultDirs (ConfigFlags -> InstallDirs (Flag PathTemplate)
configInstallDirs ConfigFlags
configFlags)
symlinkBinaries :: Verbosity
-> Platform -> Compiler
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> BuildOutcomes
-> IO ()
symlinkBinaries :: Verbosity
-> Platform
-> Compiler
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> BuildOutcomes
-> IO ()
symlinkBinaries Verbosity
verbosity Platform
platform Compiler
comp ConfigFlags
configFlags InstallFlags
installFlags
InstallPlan
plan BuildOutcomes
buildOutcomes = do
[(PackageIdentifier, UnqualComponentName, String)]
failed <- Platform
-> Compiler
-> OverwritePolicy
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> BuildOutcomes
-> IO [(PackageIdentifier, UnqualComponentName, String)]
InstallSymlink.symlinkBinaries Platform
platform Compiler
comp
OverwritePolicy
NeverOverwrite
ConfigFlags
configFlags InstallFlags
installFlags
InstallPlan
plan BuildOutcomes
buildOutcomes
case [(PackageIdentifier, UnqualComponentName, String)]
failed of
[] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(PackageIdentifier
_, UnqualComponentName
exe, String
path)] ->
Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"could not create a symlink in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bindir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow UnqualComponentName
exe String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" because the file exists there already but is not "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"managed by cabal. You can create a symlink for this executable "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"manually if you wish. The executable file has been installed at "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
[(PackageIdentifier, UnqualComponentName, String)]
exes ->
Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"could not create symlinks in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bindir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow UnqualComponentName
exe | (PackageIdentifier
_, UnqualComponentName
exe, String
_) <- [(PackageIdentifier, UnqualComponentName, String)]
exes ]
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" because the files exist there already and are not "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"managed by cabal. You can create symlinks for these executables "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"manually if you wish. The executable files have been installed at "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ String
path | (PackageIdentifier
_, UnqualComponentName
_, String
path) <- [(PackageIdentifier, UnqualComponentName, String)]
exes ]
where
bindir :: String
bindir = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag String
installSymlinkBinDir InstallFlags
installFlags)
printBuildFailures :: Verbosity -> BuildOutcomes -> IO ()
printBuildFailures :: Verbosity -> BuildOutcomes -> IO ()
printBuildFailures Verbosity
verbosity BuildOutcomes
buildOutcomes =
case [ (UnitId
pkgid, BuildFailure
failure)
| (UnitId
pkgid, Left BuildFailure
failure) <- BuildOutcomes -> [(UnitId, BuildOutcome)]
forall k a. Map k a -> [(k, a)]
Map.toList BuildOutcomes
buildOutcomes ] of
[] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(UnitId, BuildFailure)]
failed -> 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
unlines
([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Some packages failed to install:"
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [ UnitId -> String
forall a. Pretty a => a -> String
prettyShow UnitId
pkgid String -> String -> String
forall a. [a] -> [a] -> [a]
++ BuildFailure -> String
printFailureReason BuildFailure
reason
| (UnitId
pkgid, BuildFailure
reason) <- [(UnitId, BuildFailure)]
failed ]
where
printFailureReason :: BuildFailure -> String
printFailureReason BuildFailure
reason = case BuildFailure
reason of
DependentFailed PackageIdentifier
pkgid -> String
" depends on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" which failed to install."
DownloadFailed SomeException
e -> String
" failed while downloading the package."
String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
showException SomeException
e
UnpackFailed SomeException
e -> String
" failed while unpacking the package."
String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
showException SomeException
e
ConfigureFailed SomeException
e -> String
" failed during the configure step."
String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
showException SomeException
e
BuildFailed SomeException
e -> String
" failed during the building phase."
String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
showException SomeException
e
TestsFailed SomeException
e -> String
" failed during the tests phase."
String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
showException SomeException
e
InstallFailed SomeException
e -> String
" failed during the final install step."
String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
showException SomeException
e
BuildFailure
PlanningFailed -> String
" failed during the planning phase."
showException :: SomeException -> String
showException SomeException
e = String
" The exception was:\n " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
maybeOOM SomeException
e
#ifdef mingw32_HOST_OS
maybeOOM _ = ""
#else
maybeOOM :: SomeException -> String
maybeOOM SomeException
e = String -> (ExitCode -> String) -> Maybe ExitCode -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ExitCode -> String
onExitFailure (SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e)
onExitFailure :: ExitCode -> String
onExitFailure (ExitFailure Int
n)
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
9 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
9 =
String
"\nThis may be due to an out-of-memory condition."
onExitFailure ExitCode
_ = String
""
#endif
data InstallMisc = InstallMisc {
InstallMisc -> Maybe Version
libVersion :: Maybe Version
}
type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity)
performInstallations :: Verbosity
-> InstallArgs
-> InstalledPackageIndex
-> InstallPlan
-> IO BuildOutcomes
performInstallations :: Verbosity
-> InstallArgs
-> InstalledPackageIndex
-> InstallPlan
-> IO BuildOutcomes
performInstallations Verbosity
verbosity
(PackageDBStack
packageDBs, RepoContext
repoCtxt, Compiler
comp, Platform
platform, ProgramDb
progdb,
GlobalFlags
globalFlags, ConfigFlags
configFlags, ConfigExFlags
configExFlags, InstallFlags
installFlags,
HaddockFlags
haddockFlags, TestFlags
testFlags, BenchmarkFlags
_)
InstalledPackageIndex
installedPkgIndex InstallPlan
installPlan = do
Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Number of threads used: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
numJobs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
JobControl IO (UnitId, BuildOutcome)
jobControl <- if Bool
parallelInstall then Int -> IO (JobControl IO (UnitId, BuildOutcome))
forall a. WithCallStack (Int -> IO (JobControl IO a))
newParallelJobControl Int
numJobs
else IO (JobControl IO (UnitId, BuildOutcome))
forall a. IO (JobControl IO a)
newSerialJobControl
JobLimit
fetchLimit <- Int -> IO JobLimit
newJobLimit (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
numJobs Int
numFetchJobs)
Lock
installLock <- IO Lock
newLock
Lock
cacheLock <- IO Lock
newLock
Verbosity
-> JobControl IO (UnitId, BuildOutcome)
-> Bool
-> UseLogFile
-> InstallPlan
-> (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome)
-> IO BuildOutcomes
executeInstallPlan Verbosity
verbosity JobControl IO (UnitId, BuildOutcome)
jobControl Bool
keepGoing UseLogFile
useLogFile
InstallPlan
installPlan ((GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome)
-> IO BuildOutcomes)
-> (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome)
-> IO BuildOutcomes
forall a b. (a -> b) -> a -> b
$ \GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg ->
Platform
-> CompilerInfo
-> ConfigFlags
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> (ConfigFlags
-> UnresolvedPkgLoc
-> PackageDescription
-> PackageDescriptionOverride
-> IO BuildOutcome)
-> IO BuildOutcome
forall a.
Platform
-> CompilerInfo
-> ConfigFlags
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> (ConfigFlags
-> UnresolvedPkgLoc
-> PackageDescription
-> PackageDescriptionOverride
-> a)
-> a
installReadyPackage Platform
platform CompilerInfo
cinfo ConfigFlags
configFlags
GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg ((ConfigFlags
-> UnresolvedPkgLoc
-> PackageDescription
-> PackageDescriptionOverride
-> IO BuildOutcome)
-> IO BuildOutcome)
-> (ConfigFlags
-> UnresolvedPkgLoc
-> PackageDescription
-> PackageDescriptionOverride
-> IO BuildOutcome)
-> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ \ConfigFlags
configFlags' UnresolvedPkgLoc
src PackageDescription
pkg PackageDescriptionOverride
pkgoverride ->
Verbosity
-> RepoContext
-> JobLimit
-> UnresolvedPkgLoc
-> (ResolvedPkgLoc -> IO BuildOutcome)
-> IO BuildOutcome
fetchSourcePackage Verbosity
verbosity RepoContext
repoCtxt JobLimit
fetchLimit UnresolvedPkgLoc
src ((ResolvedPkgLoc -> IO BuildOutcome) -> IO BuildOutcome)
-> (ResolvedPkgLoc -> IO BuildOutcome) -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ \ResolvedPkgLoc
src' ->
Verbosity
-> PackageIdentifier
-> ResolvedPkgLoc
-> String
-> (Maybe String -> IO BuildOutcome)
-> IO BuildOutcome
installLocalPackage Verbosity
verbosity (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) ResolvedPkgLoc
src' String
distPref ((Maybe String -> IO BuildOutcome) -> IO BuildOutcome)
-> (Maybe String -> IO BuildOutcome) -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ \Maybe String
mpath ->
Verbosity
-> Lock
-> Int
-> SetupScriptOptions
-> ConfigFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> Compiler
-> ProgramDb
-> Platform
-> PackageDescription
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageDescriptionOverride
-> Maybe String
-> UseLogFile
-> IO BuildOutcome
installUnpackedPackage Verbosity
verbosity Lock
installLock Int
numJobs
(InstalledPackageIndex
-> Lock
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> SetupScriptOptions
setupScriptOptions InstalledPackageIndex
installedPkgIndex
Lock
cacheLock GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg)
ConfigFlags
configFlags'
InstallFlags
installFlags HaddockFlags
haddockFlags TestFlags
testFlags
Compiler
comp ProgramDb
progdb
Platform
platform PackageDescription
pkg GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg PackageDescriptionOverride
pkgoverride Maybe String
mpath UseLogFile
useLogFile
where
cinfo :: CompilerInfo
cinfo = Compiler -> CompilerInfo
compilerInfo Compiler
comp
numJobs :: Int
numJobs = Flag (Maybe Int) -> Int
determineNumJobs (InstallFlags -> Flag (Maybe Int)
installNumJobs InstallFlags
installFlags)
numFetchJobs :: Int
numFetchJobs = Int
2
parallelInstall :: Bool
parallelInstall = Int
numJobs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
keepGoing :: Bool
keepGoing = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installKeepGoing InstallFlags
installFlags)
distPref :: String
distPref = String -> Flag String -> String
forall a. a -> Flag a -> a
fromFlagOrDefault (SetupScriptOptions -> String
useDistPref SetupScriptOptions
defaultSetupScriptOptions)
(ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags)
setupScriptOptions :: InstalledPackageIndex
-> Lock
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> SetupScriptOptions
setupScriptOptions InstalledPackageIndex
index Lock
lock GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg =
PackageDBStack
-> Compiler
-> Platform
-> ProgramDb
-> String
-> VersionRange
-> Maybe Lock
-> Bool
-> InstalledPackageIndex
-> Maybe (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc))
-> SetupScriptOptions
configureSetupScript
PackageDBStack
packageDBs
Compiler
comp
Platform
platform
ProgramDb
progdb
String
distPref
(ConfigExFlags -> Maybe Version -> VersionRange
chooseCabalVersion ConfigExFlags
configExFlags (InstallMisc -> Maybe Version
libVersion InstallMisc
miscOptions))
(Lock -> Maybe Lock
forall a. a -> Maybe a
Just Lock
lock)
Bool
parallelInstall
InstalledPackageIndex
index
(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> Maybe (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc))
forall a. a -> Maybe a
Just GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg)
reportingLevel :: ReportLevel
reportingLevel = Flag ReportLevel -> ReportLevel
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ReportLevel
installBuildReports InstallFlags
installFlags)
logsDir :: String
logsDir = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (GlobalFlags -> Flag String
globalLogsDir GlobalFlags
globalFlags)
useLogFile :: UseLogFile
useLogFile :: UseLogFile
useLogFile = (PathTemplate
-> (PackageIdentifier -> UnitId -> String, Verbosity))
-> Maybe PathTemplate -> UseLogFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\PackageIdentifier -> UnitId -> String
f -> (PackageIdentifier -> UnitId -> String
f, Verbosity
loggingVerbosity)) ((PackageIdentifier -> UnitId -> String)
-> (PackageIdentifier -> UnitId -> String, Verbosity))
-> (PathTemplate -> PackageIdentifier -> UnitId -> String)
-> PathTemplate
-> (PackageIdentifier -> UnitId -> String, Verbosity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplate -> PackageIdentifier -> UnitId -> String
substLogFileName)
Maybe PathTemplate
logFileTemplate
where
installLogFile' :: Maybe PathTemplate
installLogFile' = Flag PathTemplate -> Maybe PathTemplate
forall a. Flag a -> Maybe a
flagToMaybe (Flag PathTemplate -> Maybe PathTemplate)
-> Flag PathTemplate -> Maybe PathTemplate
forall a b. (a -> b) -> a -> b
$ InstallFlags -> Flag PathTemplate
installLogFile InstallFlags
installFlags
defaultTemplate :: PathTemplate
defaultTemplate = String -> PathTemplate
toPathTemplate (String -> PathTemplate) -> String -> PathTemplate
forall a b. (a -> b) -> a -> b
$
String
logsDir String -> String -> String
</> String
"$compiler" String -> String -> String
</> String
"$libname" String -> String -> String
<.> String
"log"
logFileTemplate :: Maybe PathTemplate
logFileTemplate :: Maybe PathTemplate
logFileTemplate
| Bool
useDefaultTemplate = PathTemplate -> Maybe PathTemplate
forall a. a -> Maybe a
Just PathTemplate
defaultTemplate
| Bool
otherwise = Maybe PathTemplate
installLogFile'
loggingVerbosity :: Verbosity
loggingVerbosity :: Verbosity
loggingVerbosity | Bool
overrideVerbosity = (Verbosity -> Verbosity) -> Verbosity -> Verbosity
modifyVerbosity (Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
max Verbosity
verbose) Verbosity
verbosity
| Bool
otherwise = Verbosity
verbosity
useDefaultTemplate :: Bool
useDefaultTemplate :: Bool
useDefaultTemplate
| ReportLevel
reportingLevel ReportLevel -> ReportLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports = Bool
True
| Maybe PathTemplate -> Bool
forall a. Maybe a -> Bool
isJust Maybe PathTemplate
installLogFile' = Bool
False
| Bool
parallelInstall = Bool
True
| Bool
otherwise = Bool
False
overrideVerbosity :: Bool
overrideVerbosity :: Bool
overrideVerbosity
| ReportLevel
reportingLevel ReportLevel -> ReportLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports = Bool
True
| Maybe PathTemplate -> Bool
forall a. Maybe a -> Bool
isJust Maybe PathTemplate
installLogFile' = Bool
True
| Bool
parallelInstall = Bool
False
| Bool
otherwise = Bool
False
substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath
substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> String
substLogFileName PathTemplate
template PackageIdentifier
pkg UnitId
uid = PathTemplate -> String
fromPathTemplate
(PathTemplate -> String)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env
(PathTemplate -> String) -> PathTemplate -> String
forall a b. (a -> b) -> a -> b
$ PathTemplate
template
where env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv (PackageIdentifier -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageIdentifier
pkg) UnitId
uid
(Compiler -> CompilerInfo
compilerInfo Compiler
comp) Platform
platform
miscOptions :: InstallMisc
miscOptions = InstallMisc :: Maybe Version -> InstallMisc
InstallMisc {
libVersion :: Maybe Version
libVersion = Flag Version -> Maybe Version
forall a. Flag a -> Maybe a
flagToMaybe (ConfigExFlags -> Flag Version
configCabalVersion ConfigExFlags
configExFlags)
}
executeInstallPlan :: Verbosity
-> JobControl IO (UnitId, BuildOutcome)
-> Bool
-> UseLogFile
-> InstallPlan
-> (ReadyPackage -> IO BuildOutcome)
-> IO BuildOutcomes
executeInstallPlan :: Verbosity
-> JobControl IO (UnitId, BuildOutcome)
-> Bool
-> UseLogFile
-> InstallPlan
-> (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome)
-> IO BuildOutcomes
executeInstallPlan Verbosity
verbosity JobControl IO (UnitId, BuildOutcome)
jobCtl Bool
keepGoing UseLogFile
useLogFile InstallPlan
plan0 GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome
installPkg =
JobControl IO (UnitId, BuildOutcome)
-> Bool
-> (ConfiguredPackage UnresolvedPkgLoc -> BuildFailure)
-> InstallPlan
-> (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome)
-> IO BuildOutcomes
forall (m :: * -> *) ipkg srcpkg result failure.
(IsUnit ipkg, IsUnit srcpkg, Monad m) =>
JobControl m (UnitId, Either failure result)
-> Bool
-> (srcpkg -> failure)
-> GenericInstallPlan ipkg srcpkg
-> (GenericReadyPackage srcpkg -> m (Either failure result))
-> m (BuildOutcomes failure result)
InstallPlan.execute
JobControl IO (UnitId, BuildOutcome)
jobCtl Bool
keepGoing ConfiguredPackage UnresolvedPkgLoc -> BuildFailure
depsFailure InstallPlan
plan0 ((GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome)
-> IO BuildOutcomes)
-> (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome)
-> IO BuildOutcomes
forall a b. (a -> b) -> a -> b
$ \GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg -> do
BuildOutcome
buildOutcome <- GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome
installPkg GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg
PackageIdentifier -> UnitId -> BuildOutcome -> IO ()
printBuildResult (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg) (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg) BuildOutcome
buildOutcome
BuildOutcome -> IO BuildOutcome
forall (m :: * -> *) a. Monad m => a -> m a
return BuildOutcome
buildOutcome
where
depsFailure :: ConfiguredPackage UnresolvedPkgLoc -> BuildFailure
depsFailure = PackageIdentifier -> BuildFailure
DependentFailed (PackageIdentifier -> BuildFailure)
-> (ConfiguredPackage UnresolvedPkgLoc -> PackageIdentifier)
-> ConfiguredPackage UnresolvedPkgLoc
-> BuildFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredPackage UnresolvedPkgLoc -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId
printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO ()
printBuildResult :: PackageIdentifier -> UnitId -> BuildOutcome -> IO ()
printBuildResult PackageIdentifier
pkgid UnitId
uid BuildOutcome
buildOutcome = case BuildOutcome
buildOutcome of
(Right BuildResult
_) -> Verbosity -> ProgressPhase -> String -> IO ()
progressMessage Verbosity
verbosity ProgressPhase
ProgressCompleted (PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid)
(Left BuildFailure
_) -> do
Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to install " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
case UseLogFile
useLogFile of
UseLogFile
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (PackageIdentifier -> UnitId -> String
mkLogFileName, Verbosity
_) -> do
let logName :: String
logName = PackageIdentifier -> UnitId -> String
mkLogFileName PackageIdentifier
pkgid UnitId
uid
String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Build log ( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
logName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ):\n"
String -> IO ()
printFile String
logName
printFile :: FilePath -> IO ()
printFile :: String -> IO ()
printFile String
path = String -> IO String
readFile String
path IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStr
installReadyPackage :: Platform -> CompilerInfo
-> ConfigFlags
-> ReadyPackage
-> (ConfigFlags -> UnresolvedPkgLoc
-> PackageDescription
-> PackageDescriptionOverride
-> a)
-> a
installReadyPackage :: Platform
-> CompilerInfo
-> ConfigFlags
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> (ConfigFlags
-> UnresolvedPkgLoc
-> PackageDescription
-> PackageDescriptionOverride
-> a)
-> a
installReadyPackage Platform
platform CompilerInfo
cinfo ConfigFlags
configFlags
(ReadyPackage (ConfiguredPackage ComponentId
ipid
(SourcePackage PackageIdentifier
_ GenericPackageDescription
gpkg UnresolvedPkgLoc
source PackageDescriptionOverride
pkgoverride)
FlagAssignment
flags OptionalStanzaSet
stanzas ComponentDeps [ConfiguredId]
deps))
ConfigFlags
-> UnresolvedPkgLoc
-> PackageDescription
-> PackageDescriptionOverride
-> a
installPkg =
ConfigFlags
-> UnresolvedPkgLoc
-> PackageDescription
-> PackageDescriptionOverride
-> a
installPkg ConfigFlags
configFlags {
configIPID :: Flag String
configIPID = String -> Flag String
forall a. a -> Flag a
toFlag (ComponentId -> String
forall a. Pretty a => a -> String
prettyShow ComponentId
ipid),
configConfigurationsFlags :: FlagAssignment
configConfigurationsFlags = FlagAssignment
flags,
configConstraints :: [PackageVersionConstraint]
configConstraints = [ PackageIdentifier -> PackageVersionConstraint
thisPackageVersionConstraint PackageIdentifier
srcid
| ConfiguredId
PackageIdentifier
srcid
(Just
(PackageDescription.CLibName
LibraryName
PackageDescription.LMainLibName))
ComponentId
_ipid
<- ComponentDeps [ConfiguredId] -> [ConfiguredId]
forall a. Monoid a => ComponentDeps a -> a
CD.nonSetupDeps ComponentDeps [ConfiguredId]
deps ],
configDependencies :: [GivenComponent]
configDependencies = [ PackageName -> LibraryName -> ComponentId -> GivenComponent
GivenComponent (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
srcid) LibraryName
cname ComponentId
dep_ipid
| ConfiguredId PackageIdentifier
srcid (Just (PackageDescription.CLibName LibraryName
cname)) ComponentId
dep_ipid
<- ComponentDeps [ConfiguredId] -> [ConfiguredId]
forall a. Monoid a => ComponentDeps a -> a
CD.nonSetupDeps ComponentDeps [ConfiguredId]
deps ],
configExactConfiguration :: Flag Bool
configExactConfiguration = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
True,
configBenchmarks :: Flag Bool
configBenchmarks = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False,
configTests :: Flag Bool
configTests = Bool -> Flag Bool
forall a. a -> Flag a
toFlag (OptionalStanza
TestStanzas OptionalStanza -> OptionalStanzaSet -> Bool
`optStanzaSetMember` OptionalStanzaSet
stanzas)
} UnresolvedPkgLoc
source PackageDescription
pkg PackageDescriptionOverride
pkgoverride
where
pkg :: PackageDescription
pkg = case FlagAssignment
-> ComponentRequestedSpec
-> (Dependency -> Bool)
-> Platform
-> CompilerInfo
-> [PackageVersionConstraint]
-> GenericPackageDescription
-> Either [Dependency] (PackageDescription, FlagAssignment)
finalizePD FlagAssignment
flags (OptionalStanzaSet -> ComponentRequestedSpec
enableStanzas OptionalStanzaSet
stanzas)
(Bool -> Dependency -> Bool
forall a b. a -> b -> a
const Bool
True)
Platform
platform CompilerInfo
cinfo [] GenericPackageDescription
gpkg of
Left [Dependency]
_ -> String -> PackageDescription
forall a. HasCallStack => String -> a
error String
"finalizePD ReadyPackage failed"
Right (PackageDescription
desc, FlagAssignment
_) -> PackageDescription
desc
fetchSourcePackage
:: Verbosity
-> RepoContext
-> JobLimit
-> UnresolvedPkgLoc
-> (ResolvedPkgLoc -> IO BuildOutcome)
-> IO BuildOutcome
fetchSourcePackage :: Verbosity
-> RepoContext
-> JobLimit
-> UnresolvedPkgLoc
-> (ResolvedPkgLoc -> IO BuildOutcome)
-> IO BuildOutcome
fetchSourcePackage Verbosity
verbosity RepoContext
repoCtxt JobLimit
fetchLimit UnresolvedPkgLoc
src ResolvedPkgLoc -> IO BuildOutcome
installPkg = do
Maybe ResolvedPkgLoc
fetched <- UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
checkFetched UnresolvedPkgLoc
src
case Maybe ResolvedPkgLoc
fetched of
Just ResolvedPkgLoc
src' -> ResolvedPkgLoc -> IO BuildOutcome
installPkg ResolvedPkgLoc
src'
Maybe ResolvedPkgLoc
Nothing -> (SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
DownloadFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
ResolvedPkgLoc
loc <- JobLimit -> IO ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a. JobLimit -> IO a -> IO a
withJobLimit JobLimit
fetchLimit (IO ResolvedPkgLoc -> IO ResolvedPkgLoc)
-> IO ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a b. (a -> b) -> a -> b
$
Verbosity -> RepoContext -> UnresolvedPkgLoc -> IO ResolvedPkgLoc
fetchPackage Verbosity
verbosity RepoContext
repoCtxt UnresolvedPkgLoc
src
ResolvedPkgLoc -> IO BuildOutcome
installPkg ResolvedPkgLoc
loc
installLocalPackage
:: Verbosity
-> PackageIdentifier -> ResolvedPkgLoc -> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalPackage :: Verbosity
-> PackageIdentifier
-> ResolvedPkgLoc
-> String
-> (Maybe String -> IO BuildOutcome)
-> IO BuildOutcome
installLocalPackage Verbosity
verbosity PackageIdentifier
pkgid ResolvedPkgLoc
location String
distPref Maybe String -> IO BuildOutcome
installPkg =
case ResolvedPkgLoc
location of
LocalUnpackedPackage String
dir ->
Maybe String -> IO BuildOutcome
installPkg (String -> Maybe String
forall a. a -> Maybe a
Just String
dir)
RemoteSourceRepoPackage SourceRepoMaybe
_repo String
dir ->
Maybe String -> IO BuildOutcome
installPkg (String -> Maybe String
forall a. a -> Maybe a
Just String
dir)
LocalTarballPackage String
tarballPath ->
Verbosity
-> PackageIdentifier
-> String
-> String
-> (Maybe String -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage Verbosity
verbosity
PackageIdentifier
pkgid String
tarballPath String
distPref Maybe String -> IO BuildOutcome
installPkg
RemoteTarballPackage URI
_ String
tarballPath ->
Verbosity
-> PackageIdentifier
-> String
-> String
-> (Maybe String -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage Verbosity
verbosity
PackageIdentifier
pkgid String
tarballPath String
distPref Maybe String -> IO BuildOutcome
installPkg
RepoTarballPackage Repo
_ PackageIdentifier
_ String
tarballPath ->
Verbosity
-> PackageIdentifier
-> String
-> String
-> (Maybe String -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage Verbosity
verbosity
PackageIdentifier
pkgid String
tarballPath String
distPref Maybe String -> IO BuildOutcome
installPkg
installLocalTarballPackage
:: Verbosity
-> PackageIdentifier -> FilePath -> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage :: Verbosity
-> PackageIdentifier
-> String
-> String
-> (Maybe String -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage Verbosity
verbosity PackageIdentifier
pkgid
String
tarballPath String
distPref Maybe String -> IO BuildOutcome
installPkg = do
String
tmp <- IO String
getTemporaryDirectory
Verbosity
-> String
-> String
-> (String -> IO BuildOutcome)
-> IO BuildOutcome
forall a. Verbosity -> String -> String -> (String -> IO a) -> IO a
withTempDirectory Verbosity
verbosity String
tmp String
"cabal-tmp" ((String -> IO BuildOutcome) -> IO BuildOutcome)
-> (String -> IO BuildOutcome) -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ \String
tmpDirPath ->
(SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
UnpackFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
let relUnpackedPath :: String
relUnpackedPath = PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid
absUnpackedPath :: String
absUnpackedPath = String
tmpDirPath String -> String -> String
</> String
relUnpackedPath
descFilePath :: String
descFilePath = String
absUnpackedPath
String -> String -> String
</> PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid) String -> String -> String
<.> String
"cabal"
Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Extracting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tarballPath
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tmpDirPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
String -> String -> String -> IO ()
extractTarGzFile String
tmpDirPath String
relUnpackedPath String
tarballPath
Bool
exists <- String -> IO Bool
doesFileExist String
descFilePath
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (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
"Package .cabal file not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
descFilePath
String -> IO ()
maybeRenameDistDir String
absUnpackedPath
Maybe String -> IO BuildOutcome
installPkg (String -> Maybe String
forall a. a -> Maybe a
Just String
absUnpackedPath)
where
maybeRenameDistDir :: FilePath -> IO ()
maybeRenameDistDir :: String -> IO ()
maybeRenameDistDir String
absUnpackedPath = do
let distDirPath :: String
distDirPath = String
absUnpackedPath String -> String -> String
</> String
defaultDistPref
distDirPathTmp :: String
distDirPathTmp = String
absUnpackedPath String -> String -> String
</> (String
defaultDistPref String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-tmp")
distDirPathNew :: String
distDirPathNew = String
absUnpackedPath String -> String -> String
</> String
distPref
Bool
distDirExists <- String -> IO Bool
doesDirectoryExist String
distDirPath
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
distDirExists
Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
distDirPath String -> String -> Bool
`equalFilePath` String
distDirPathNew)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Renaming '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
distDirPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' to '"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
distDirPathTmp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."
String -> String -> IO ()
renameDirectory String
distDirPath String
distDirPathTmp
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
distDirPath String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
distDirPathNew) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
False String
distDirPath
Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Renaming '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
distDirPathTmp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' to '"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
distDirPathNew String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."
String -> String -> IO ()
renameDirectory String
distDirPathTmp String
distDirPathNew
installUnpackedPackage
:: Verbosity
-> Lock
-> Int
-> SetupScriptOptions
-> ConfigFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> Compiler
-> ProgramDb
-> Platform
-> PackageDescription
-> ReadyPackage
-> PackageDescriptionOverride
-> Maybe FilePath
-> UseLogFile
-> IO BuildOutcome
installUnpackedPackage :: Verbosity
-> Lock
-> Int
-> SetupScriptOptions
-> ConfigFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> Compiler
-> ProgramDb
-> Platform
-> PackageDescription
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageDescriptionOverride
-> Maybe String
-> UseLogFile
-> IO BuildOutcome
installUnpackedPackage Verbosity
verbosity Lock
installLock Int
numJobs
SetupScriptOptions
scriptOptions
ConfigFlags
configFlags InstallFlags
installFlags HaddockFlags
haddockFlags TestFlags
testFlags Compiler
comp ProgramDb
progdb
Platform
platform PackageDescription
pkg GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg PackageDescriptionOverride
pkgoverride Maybe String
workingDir UseLogFile
useLogFile = do
case PackageDescriptionOverride
pkgoverride of
PackageDescriptionOverride
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
pkgtxt -> do
let descFilePath :: String
descFilePath = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"." Maybe String
workingDir
String -> String -> String
</> PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid) String -> String -> String
<.> String
"cabal"
Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Updating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid) String -> String -> String
<.> String
"cabal"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with the latest revision from the index."
String -> ByteString -> IO ()
writeFileAtomic String
descFilePath ByteString
pkgtxt
ConfigFlags
configFlags' <- ConfigFlags -> IO ConfigFlags
addDefaultInstallDirs ConfigFlags
configFlags
let configureFlags :: Version -> ConfigFlags
configureFlags :: Version -> ConfigFlags
configureFlags = ConfigFlags -> Version -> ConfigFlags
filterConfigureFlags ConfigFlags
configFlags' {
configVerbosity :: Flag Verbosity
configVerbosity = Verbosity -> Flag Verbosity
forall a. a -> Flag a
toFlag Verbosity
verbosity'
}
Maybe String
mLogPath <- IO (Maybe String)
maybeLogPath
(String -> IO ())
-> Maybe String -> IO BuildOutcome -> IO BuildOutcome
forall a. (String -> IO ()) -> Maybe String -> IO a -> IO a
logDirChange ((String -> IO ())
-> (String -> String -> IO ()) -> Maybe String -> String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO () -> String -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) String -> String -> IO ()
appendFile Maybe String
mLogPath) Maybe String
workingDir (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
(SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
ConfigureFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressStarting
CommandUI ConfigFlags
-> (Version -> ConfigFlags) -> Maybe String -> IO ()
forall flags.
CommandUI flags -> (Version -> flags) -> Maybe String -> IO ()
setup CommandUI ConfigFlags
configureCommand Version -> ConfigFlags
configureFlags Maybe String
mLogPath
(SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
BuildFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressBuilding
CommandUI BuildFlags
-> (Version -> BuildFlags) -> Maybe String -> IO ()
forall flags.
CommandUI flags -> (Version -> flags) -> Maybe String -> IO ()
setup CommandUI BuildFlags
buildCommand' Version -> BuildFlags
forall p. p -> BuildFlags
buildFlags Maybe String
mLogPath
DocsResult
docsResult <- if Bool
shouldHaddock
then (do CommandUI HaddockFlags
-> (Version -> HaddockFlags) -> Maybe String -> IO ()
forall flags.
CommandUI flags -> (Version -> flags) -> Maybe String -> IO ()
setup CommandUI HaddockFlags
haddockCommand Version -> HaddockFlags
forall p. p -> HaddockFlags
haddockFlags' Maybe String
mLogPath
DocsResult -> IO DocsResult
forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsOk)
IO DocsResult -> (IOError -> IO DocsResult) -> IO DocsResult
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` (\IOError
_ -> DocsResult -> IO DocsResult
forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsFailed)
IO DocsResult -> (ExitCode -> IO DocsResult) -> IO DocsResult
forall a. IO a -> (ExitCode -> IO a) -> IO a
`catchExit` (\ExitCode
_ -> DocsResult -> IO DocsResult
forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsFailed)
else DocsResult -> IO DocsResult
forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsNotTried
(SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
TestsFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
testsEnabled Bool -> Bool -> Bool
&& PackageDescription -> Bool
PackageDescription.hasTests PackageDescription
pkg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
CommandUI TestFlags
-> (Version -> TestFlags) -> Maybe String -> IO ()
forall flags.
CommandUI flags -> (Version -> flags) -> Maybe String -> IO ()
setup CommandUI TestFlags
Cabal.testCommand Version -> TestFlags
testFlags' Maybe String
mLogPath
let testsResult :: TestsResult
testsResult | Bool
testsEnabled = TestsResult
TestsOk
| Bool
otherwise = TestsResult
TestsNotTried
(SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
InstallFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ Lock -> IO BuildOutcome -> IO BuildOutcome
forall a. Lock -> IO a -> IO a
criticalSection Lock
installLock (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
Verbosity
-> UnitId
-> ConfigFlags
-> CompilerInfo
-> Platform
-> PackageDescription
-> IO ()
-> IO ()
forall a.
Verbosity
-> UnitId
-> ConfigFlags
-> CompilerInfo
-> Platform
-> PackageDescription
-> IO a
-> IO a
withWin32SelfUpgrade Verbosity
verbosity UnitId
uid ConfigFlags
configFlags
CompilerInfo
cinfo Platform
platform PackageDescription
pkg (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
CommandUI CopyFlags
-> (Version -> CopyFlags) -> Maybe String -> IO ()
forall flags.
CommandUI flags -> (Version -> flags) -> Maybe String -> IO ()
setup CommandUI CopyFlags
Cabal.copyCommand Version -> CopyFlags
forall p. p -> CopyFlags
copyFlags Maybe String
mLogPath
[InstalledPackageInfo]
ipkgs <- Maybe String -> IO [InstalledPackageInfo]
genPkgConfs Maybe String
mLogPath
let ipkgs' :: [InstalledPackageInfo]
ipkgs' = case [InstalledPackageInfo]
ipkgs of
[InstalledPackageInfo
ipkg] -> [InstalledPackageInfo
ipkg { installedUnitId :: UnitId
Installed.installedUnitId = UnitId
uid }]
[InstalledPackageInfo]
_ -> [InstalledPackageInfo]
ipkgs
let packageDBs :: PackageDBStack
packageDBs = Bool -> [Maybe PackageDB] -> PackageDBStack
interpretPackageDbFlags
(Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags))
(ConfigFlags -> [Maybe PackageDB]
configPackageDBs ConfigFlags
configFlags)
[InstalledPackageInfo] -> (InstalledPackageInfo -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [InstalledPackageInfo]
ipkgs' ((InstalledPackageInfo -> IO ()) -> IO ())
-> (InstalledPackageInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \InstalledPackageInfo
ipkg' ->
Verbosity
-> Compiler
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity Compiler
comp ProgramDb
progdb
PackageDBStack
packageDBs InstalledPackageInfo
ipkg'
RegisterOptions
defaultRegisterOptions
BuildOutcome -> IO BuildOutcome
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildResult -> BuildOutcome
forall a b. b -> Either a b
Right (DocsResult
-> TestsResult -> Maybe InstalledPackageInfo -> BuildResult
BuildResult DocsResult
docsResult TestsResult
testsResult ((InstalledPackageInfo -> Bool)
-> [InstalledPackageInfo] -> Maybe InstalledPackageInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
==UnitId
uid)(UnitId -> Bool)
-> (InstalledPackageInfo -> UnitId) -> InstalledPackageInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.InstalledPackageInfo -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId) [InstalledPackageInfo]
ipkgs')))
where
pkgid :: PackageIdentifier
pkgid = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
uid :: UnitId
uid = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg
cinfo :: CompilerInfo
cinfo = Compiler -> CompilerInfo
compilerInfo Compiler
comp
buildCommand' :: CommandUI BuildFlags
buildCommand' = ProgramDb -> CommandUI BuildFlags
buildCommand ProgramDb
progdb
dispname :: String
dispname = PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid
isParallelBuild :: Bool
isParallelBuild = Int
numJobs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
noticeProgress :: ProgressPhase -> IO ()
noticeProgress ProgressPhase
phase = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isParallelBuild (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> ProgressPhase -> String -> IO ()
progressMessage Verbosity
verbosity ProgressPhase
phase String
dispname
buildFlags :: p -> BuildFlags
buildFlags p
_ = BuildFlags
emptyBuildFlags {
buildDistPref :: Flag String
buildDistPref = ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags,
buildVerbosity :: Flag Verbosity
buildVerbosity = Verbosity -> Flag Verbosity
forall a. a -> Flag a
toFlag Verbosity
verbosity'
}
shouldHaddock :: Bool
shouldHaddock = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDocumentation InstallFlags
installFlags)
haddockFlags' :: p -> HaddockFlags
haddockFlags' p
_ = HaddockFlags
haddockFlags {
haddockVerbosity :: Flag Verbosity
haddockVerbosity = Verbosity -> Flag Verbosity
forall a. a -> Flag a
toFlag Verbosity
verbosity',
haddockDistPref :: Flag String
haddockDistPref = ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags
}
testsEnabled :: Bool
testsEnabled = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags)
Bool -> Bool -> Bool
&& Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InstallFlags -> Flag Bool
installRunTests InstallFlags
installFlags)
testFlags' :: Version -> TestFlags
testFlags' = TestFlags -> Version -> TestFlags
filterTestFlags TestFlags
testFlags {
testDistPref :: Flag String
Cabal.testDistPref = ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags
}
copyFlags :: p -> CopyFlags
copyFlags p
_ = CopyFlags
Cabal.emptyCopyFlags {
copyDistPref :: Flag String
Cabal.copyDistPref = ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags,
copyDest :: Flag CopyDest
Cabal.copyDest = CopyDest -> Flag CopyDest
forall a. a -> Flag a
toFlag CopyDest
InstallDirs.NoCopyDest,
copyVerbosity :: Flag Verbosity
Cabal.copyVerbosity = Verbosity -> Flag Verbosity
forall a. a -> Flag a
toFlag Verbosity
verbosity'
}
shouldRegister :: Bool
shouldRegister = PackageDescription -> Bool
PackageDescription.hasLibs PackageDescription
pkg
registerFlags :: p -> RegisterFlags
registerFlags p
_ = RegisterFlags
Cabal.emptyRegisterFlags {
regDistPref :: Flag String
Cabal.regDistPref = ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags,
regVerbosity :: Flag Verbosity
Cabal.regVerbosity = Verbosity -> Flag Verbosity
forall a. a -> Flag a
toFlag Verbosity
verbosity'
}
verbosity' :: Verbosity
verbosity' = Verbosity
-> ((PackageIdentifier -> UnitId -> String, Verbosity)
-> Verbosity)
-> UseLogFile
-> Verbosity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Verbosity
verbosity (PackageIdentifier -> UnitId -> String, Verbosity) -> Verbosity
forall a b. (a, b) -> b
snd UseLogFile
useLogFile
tempTemplate :: String -> String
tempTemplate String
name = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid
addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags
addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags
addDefaultInstallDirs ConfigFlags
configFlags' = do
InstallDirTemplates
defInstallDirs <- CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
InstallDirs.defaultInstallDirs CompilerFlavor
flavor Bool
userInstall Bool
False
ConfigFlags -> IO ConfigFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (ConfigFlags -> IO ConfigFlags) -> ConfigFlags -> IO ConfigFlags
forall a b. (a -> b) -> a -> b
$ ConfigFlags
configFlags' {
configInstallDirs :: InstallDirs (Flag PathTemplate)
configInstallDirs = (PathTemplate -> Flag PathTemplate)
-> InstallDirTemplates -> InstallDirs (Flag PathTemplate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> Flag PathTemplate
forall a. a -> Flag a
Cabal.Flag (InstallDirTemplates -> InstallDirs (Flag PathTemplate))
-> (InstallDirTemplates -> InstallDirTemplates)
-> InstallDirTemplates
-> InstallDirs (Flag PathTemplate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
PathTemplateEnv -> InstallDirTemplates -> InstallDirTemplates
InstallDirs.substituteInstallDirTemplates PathTemplateEnv
env (InstallDirTemplates -> InstallDirs (Flag PathTemplate))
-> InstallDirTemplates -> InstallDirs (Flag PathTemplate)
forall a b. (a -> b) -> a -> b
$
(PathTemplate -> Flag PathTemplate -> PathTemplate)
-> InstallDirTemplates
-> InstallDirs (Flag PathTemplate)
-> InstallDirTemplates
forall a b c.
(a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
InstallDirs.combineInstallDirs PathTemplate -> Flag PathTemplate -> PathTemplate
forall a. a -> Flag a -> a
fromFlagOrDefault
InstallDirTemplates
defInstallDirs (ConfigFlags -> InstallDirs (Flag PathTemplate)
configInstallDirs ConfigFlags
configFlags)
}
where
CompilerId CompilerFlavor
flavor Version
_ = CompilerInfo -> CompilerId
compilerInfoId CompilerInfo
cinfo
env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv PackageIdentifier
pkgid UnitId
uid CompilerInfo
cinfo Platform
platform
userInstall :: Bool
userInstall = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
defaultUserInstall
(ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags')
genPkgConfs :: Maybe FilePath
-> IO [Installed.InstalledPackageInfo]
genPkgConfs :: Maybe String -> IO [InstalledPackageInfo]
genPkgConfs Maybe String
mLogPath =
if Bool
shouldRegister then do
String
tmp <- IO String
getTemporaryDirectory
Verbosity
-> String
-> String
-> (String -> IO [InstalledPackageInfo])
-> IO [InstalledPackageInfo]
forall a. Verbosity -> String -> String -> (String -> IO a) -> IO a
withTempDirectory Verbosity
verbosity String
tmp (String -> String
tempTemplate String
"pkgConf") ((String -> IO [InstalledPackageInfo])
-> IO [InstalledPackageInfo])
-> (String -> IO [InstalledPackageInfo])
-> IO [InstalledPackageInfo]
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
let pkgConfDest :: String
pkgConfDest = String
dir String -> String -> String
</> String
"pkgConf"
registerFlags' :: p -> RegisterFlags
registerFlags' p
version = (p -> RegisterFlags
forall p. p -> RegisterFlags
registerFlags p
version) {
regGenPkgConf :: Flag (Maybe String)
Cabal.regGenPkgConf = Maybe String -> Flag (Maybe String)
forall a. a -> Flag a
toFlag (String -> Maybe String
forall a. a -> Maybe a
Just String
pkgConfDest)
}
CommandUI RegisterFlags
-> (Version -> RegisterFlags) -> Maybe String -> IO ()
forall flags.
CommandUI flags -> (Version -> flags) -> Maybe String -> IO ()
setup CommandUI RegisterFlags
Cabal.registerCommand Version -> RegisterFlags
forall p. p -> RegisterFlags
registerFlags' Maybe String
mLogPath
Bool
is_dir <- String -> IO Bool
doesDirectoryExist String
pkgConfDest
let notHidden :: String -> Bool
notHidden = Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isHidden
isHidden :: String -> Bool
isHidden String
name = String
"." String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
name
if Bool
is_dir
then (String -> IO InstalledPackageInfo)
-> [String] -> IO [InstalledPackageInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> String -> IO InstalledPackageInfo
readPkgConf String
pkgConfDest) ([String] -> IO [InstalledPackageInfo])
-> ([String] -> [String]) -> [String] -> IO [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
notHidden
([String] -> IO [InstalledPackageInfo])
-> IO [String] -> IO [InstalledPackageInfo]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO [String]
getDirectoryContents String
pkgConfDest
else (InstalledPackageInfo -> [InstalledPackageInfo])
-> IO InstalledPackageInfo -> IO [InstalledPackageInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InstalledPackageInfo
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a. a -> [a] -> [a]
:[]) (IO InstalledPackageInfo -> IO [InstalledPackageInfo])
-> IO InstalledPackageInfo -> IO [InstalledPackageInfo]
forall a b. (a -> b) -> a -> b
$ String -> String -> IO InstalledPackageInfo
readPkgConf String
"." String
pkgConfDest
else [InstalledPackageInfo] -> IO [InstalledPackageInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
readPkgConf :: FilePath -> FilePath
-> IO Installed.InstalledPackageInfo
readPkgConf :: String -> String -> IO InstalledPackageInfo
readPkgConf String
pkgConfDir String
pkgConfFile = do
ByteString
pkgConfText <- String -> IO ByteString
BS.readFile (String
pkgConfDir String -> String -> String
</> String
pkgConfFile)
case ByteString
-> Either (NonEmpty String) ([String], InstalledPackageInfo)
Installed.parseInstalledPackageInfo ByteString
pkgConfText of
Left NonEmpty String
perrors -> String -> IO InstalledPackageInfo
forall a. String -> IO a
pkgConfParseFailed (String -> IO InstalledPackageInfo)
-> String -> IO InstalledPackageInfo
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
perrors
Right ([String]
warns, InstalledPackageInfo
pkgConf) -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
warns) (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] -> String
unlines [String]
warns
InstalledPackageInfo -> IO InstalledPackageInfo
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageInfo
pkgConf
pkgConfParseFailed :: String -> IO a
pkgConfParseFailed :: String -> IO a
pkgConfParseFailed String
perror =
Verbosity -> String -> IO a
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Couldn't parse the output of 'setup register --gen-pkg-config':"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
perror
maybeLogPath :: IO (Maybe FilePath)
maybeLogPath :: IO (Maybe String)
maybeLogPath =
case UseLogFile
useLogFile of
UseLogFile
Nothing -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Just (PackageIdentifier -> UnitId -> String
mkLogFileName, Verbosity
_) -> do
let logFileName :: String
logFileName = PackageIdentifier -> UnitId -> String
mkLogFileName (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) UnitId
uid
logDir :: String
logDir = String -> String
takeDirectory String
logFileName
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
logDir) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
logDir
Bool
logFileExists <- String -> IO Bool
doesFileExist String
logFileName
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
logFileExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
logFileName
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
logFileName)
setup :: CommandUI flags -> (Version -> flags) -> Maybe String -> IO ()
setup CommandUI flags
cmd Version -> flags
flags Maybe String
mLogPath =
IO (Maybe Handle)
-> (Maybe Handle -> IO ()) -> (Maybe Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
((String -> IO Handle) -> Maybe String -> IO (Maybe Handle)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\String
path -> String -> IOMode -> IO Handle
openFile String
path IOMode
AppendMode) Maybe String
mLogPath)
((Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Handle -> IO ()
hClose)
(\Maybe Handle
logFileHandle ->
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> IO ()
forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> IO ()
setupWrapper Verbosity
verbosity
SetupScriptOptions
scriptOptions { useLoggingHandle :: Maybe Handle
useLoggingHandle = Maybe Handle
logFileHandle
, useWorkingDir :: Maybe String
useWorkingDir = Maybe String
workingDir }
(PackageDescription -> Maybe PackageDescription
forall a. a -> Maybe a
Just PackageDescription
pkg)
CommandUI flags
cmd Version -> flags
flags ([String] -> Version -> [String]
forall a b. a -> b -> a
const []))
onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome
onFailure :: (SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
result IO BuildOutcome
action =
IO BuildOutcome
action IO BuildOutcome -> [Handler BuildOutcome] -> IO BuildOutcome
forall a. IO a -> [Handler a] -> IO a
`catches`
[ (IOError -> IO BuildOutcome) -> Handler BuildOutcome
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOError -> IO BuildOutcome) -> Handler BuildOutcome)
-> (IOError -> IO BuildOutcome) -> Handler BuildOutcome
forall a b. (a -> b) -> a -> b
$ \IOError
ioe -> IOError -> IO BuildOutcome
forall e. Exception e => e -> IO BuildOutcome
handler (IOError
ioe :: IOException)
, (ExitCode -> IO BuildOutcome) -> Handler BuildOutcome
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ExitCode -> IO BuildOutcome) -> Handler BuildOutcome)
-> (ExitCode -> IO BuildOutcome) -> Handler BuildOutcome
forall a b. (a -> b) -> a -> b
$ \ExitCode
exit -> ExitCode -> IO BuildOutcome
forall e. Exception e => e -> IO BuildOutcome
handler (ExitCode
exit :: ExitCode)
]
where
handler :: Exception e => e -> IO BuildOutcome
handler :: e -> IO BuildOutcome
handler = BuildOutcome -> IO BuildOutcome
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildOutcome -> IO BuildOutcome)
-> (e -> BuildOutcome) -> e -> IO BuildOutcome
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildFailure -> BuildOutcome
forall a b. a -> Either a b
Left (BuildFailure -> BuildOutcome)
-> (e -> BuildFailure) -> e -> BuildOutcome
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> BuildFailure
result (SomeException -> BuildFailure)
-> (e -> SomeException) -> e -> BuildFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SomeException
forall e. Exception e => e -> SomeException
toException
withWin32SelfUpgrade :: Verbosity
-> UnitId
-> ConfigFlags
-> CompilerInfo
-> Platform
-> PackageDescription
-> IO a -> IO a
withWin32SelfUpgrade :: Verbosity
-> UnitId
-> ConfigFlags
-> CompilerInfo
-> Platform
-> PackageDescription
-> IO a
-> IO a
withWin32SelfUpgrade Verbosity
_ UnitId
_ ConfigFlags
_ CompilerInfo
_ Platform
_ PackageDescription
_ IO a
action | OS
buildOS OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
/= OS
Windows = IO a
action
withWin32SelfUpgrade Verbosity
verbosity UnitId
uid ConfigFlags
configFlags CompilerInfo
cinfo Platform
platform PackageDescription
pkg IO a
action = do
InstallDirTemplates
defaultDirs <- CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
InstallDirs.defaultInstallDirs
CompilerFlavor
compFlavor
(Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags))
(PackageDescription -> Bool
PackageDescription.hasLibs PackageDescription
pkg)
Verbosity -> [String] -> IO a -> IO a
forall a. Verbosity -> [String] -> IO a -> IO a
Win32SelfUpgrade.possibleSelfUpgrade Verbosity
verbosity
(InstallDirTemplates -> [String]
exeInstallPaths InstallDirTemplates
defaultDirs) IO a
action
where
pkgid :: PackageIdentifier
pkgid = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
(CompilerId CompilerFlavor
compFlavor Version
_) = CompilerInfo -> CompilerId
compilerInfoId CompilerInfo
cinfo
exeInstallPaths :: InstallDirTemplates -> [String]
exeInstallPaths InstallDirTemplates
defaultDirs =
[ InstallDirs String -> String
forall dir. InstallDirs dir -> dir
InstallDirs.bindir InstallDirs String
absoluteDirs String -> String -> String
</> String
exeName String -> String -> String
<.> Platform -> String
exeExtension Platform
buildPlatform
| Executable
exe <- PackageDescription -> [Executable]
PackageDescription.executables PackageDescription
pkg
, BuildInfo -> Bool
PackageDescription.buildable (Executable -> BuildInfo
PackageDescription.buildInfo Executable
exe)
, let exeName :: String
exeName = String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow (Executable -> UnqualComponentName
PackageDescription.exeName Executable
exe) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix
prefix :: String
prefix = PathTemplate -> String
substTemplate PathTemplate
prefixTemplate
suffix :: String
suffix = PathTemplate -> String
substTemplate PathTemplate
suffixTemplate ]
where
fromFlagTemplate :: Flag PathTemplate -> PathTemplate
fromFlagTemplate = PathTemplate -> Flag PathTemplate -> PathTemplate
forall a. a -> Flag a -> a
fromFlagOrDefault (String -> PathTemplate
InstallDirs.toPathTemplate String
"")
prefixTemplate :: PathTemplate
prefixTemplate = Flag PathTemplate -> PathTemplate
fromFlagTemplate (ConfigFlags -> Flag PathTemplate
configProgPrefix ConfigFlags
configFlags)
suffixTemplate :: PathTemplate
suffixTemplate = Flag PathTemplate -> PathTemplate
fromFlagTemplate (ConfigFlags -> Flag PathTemplate
configProgSuffix ConfigFlags
configFlags)
templateDirs :: InstallDirTemplates
templateDirs = (PathTemplate -> Flag PathTemplate -> PathTemplate)
-> InstallDirTemplates
-> InstallDirs (Flag PathTemplate)
-> InstallDirTemplates
forall a b c.
(a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
InstallDirs.combineInstallDirs PathTemplate -> Flag PathTemplate -> PathTemplate
forall a. a -> Flag a -> a
fromFlagOrDefault
InstallDirTemplates
defaultDirs (ConfigFlags -> InstallDirs (Flag PathTemplate)
configInstallDirs ConfigFlags
configFlags)
absoluteDirs :: InstallDirs String
absoluteDirs = PackageIdentifier
-> UnitId
-> CompilerInfo
-> CopyDest
-> Platform
-> InstallDirTemplates
-> InstallDirs String
InstallDirs.absoluteInstallDirs
PackageIdentifier
pkgid UnitId
uid
CompilerInfo
cinfo CopyDest
InstallDirs.NoCopyDest
Platform
platform InstallDirTemplates
templateDirs
substTemplate :: PathTemplate -> String
substTemplate = PathTemplate -> String
InstallDirs.fromPathTemplate
(PathTemplate -> String)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
InstallDirs.substPathTemplate PathTemplateEnv
env
where env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
InstallDirs.initialPathTemplateEnv PackageIdentifier
pkgid UnitId
uid
CompilerInfo
cinfo Platform
platform