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

   1 {-# LANGUAGE CPP #-}
   2
   3 -----------------------------------------------------------------------------
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Client.Install
   9 -- Copyright   :  (c) 2005 David Himmelstrup
  10 --                    2007 Bjorn Bringert
  11 --                    2007-2010 Duncan Coutts
  12 -- License     :  BSD-like
  13 --
  14 -- Maintainer  :  cabal-devel@haskell.org
  15 -- Stability   :  provisional
  16 -- Portability :  portable
  17 --
  18 -- High level interface to package installation.
  19 module Distribution.Client.Install
  20   ( -- * High-level interface
  21     install
  22
  23     -- * Lower-level interface that allows to manipulate the install plan
  24   , makeInstallContext
  25   , makeInstallPlan
  26   , processInstallPlan
  27   , InstallArgs
  28   , InstallContext
  29
  30     -- * Prune certain packages from the install plan
  31   , pruneInstallPlan
  32   ) where
  33
  34 import Distribution.Client.Compat.Prelude
  35 import Distribution.Utils.Generic (safeLast)
  36 import Prelude ()
  37
  38 import Control.Exception as Exception
  39   ( Handler (Handler)
  40   , bracket
  41   , catches
  42   , handleJust
  43   )
  44 import qualified Data.List.NonEmpty as NE
  45 import qualified Data.Map as Map
  46 import System.Directory
  47   ( createDirectoryIfMissing
  48   , doesDirectoryExist
  49   , doesFileExist
  50   , getDirectoryContents
  51   , getTemporaryDirectory
  52   , removeFile
  53   , renameDirectory
  54   )
  55 import System.FilePath
  56   ( equalFilePath
  57   , takeDirectory
  58   , (<.>)
  59   , (</>)
  60   )
  61 import System.IO
  62   ( IOMode (AppendMode)
  63   , hClose
  64   , openFile
  65   )
  66 import System.IO.Error
  67   ( ioeGetFileName
  68   , isDoesNotExistError
  69   )
  70
  71 import Distribution.Client.BuildReports.Anonymous (showBuildReport)
  72 import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
  73 import qualified Distribution.Client.BuildReports.Storage as BuildReports
  74   ( fromInstallPlan
  75   , fromPlanningFailure
  76   , storeAnonymous
  77   , storeLocal
  78   )
  79 import Distribution.Client.BuildReports.Types
  80   ( ReportLevel (..)
  81   )
  82 import Distribution.Client.Config
  83   ( defaultReportsDir
  84   , defaultUserInstall
  85   )
  86 import Distribution.Client.Configure
  87   ( checkConfigExFlags
  88   , chooseCabalVersion
  89   , configureSetupScript
  90   )
  91 import Distribution.Client.Dependency
  92 import Distribution.Client.FetchUtils
  93 import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
  94 import Distribution.Client.HttpUtils
  95   ( HttpTransport (..)
  96   )
  97 import Distribution.Client.IndexUtils as IndexUtils
  98   ( getInstalledPackages
  99   , getSourcePackagesAtIndexState
 100   )
 101 import Distribution.Client.InstallPlan (InstallPlan)
 102 import qualified Distribution.Client.InstallPlan as InstallPlan
 103 import qualified Distribution.Client.InstallSymlink as InstallSymlink
 104   ( symlinkBinaries
 105   )
 106 import Distribution.Client.JobControl
 107 import Distribution.Client.Setup
 108   ( ConfigExFlags (..)
 109   , ConfigFlags (..)
 110   , GlobalFlags (..)
 111   , InstallFlags (..)
 112   , RepoContext (..)
 113   , configureCommand
 114   , filterConfigureFlags
 115   , filterTestFlags
 116   )
 117 import Distribution.Client.SetupWrapper
 118   ( SetupScriptOptions (..)
 119   , defaultSetupScriptOptions
 120   , setupWrapper
 121   )
 122 import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
 123 import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
 124 import Distribution.Client.Tar (extractTarGzFile)
 125 import Distribution.Client.Targets
 126 import Distribution.Client.Types as Source
 127 import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))
 128 import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
 129 import qualified Distribution.InstalledPackageInfo as Installed
 130 import Distribution.Solver.Types.PackageFixedDeps
 131
 132 import qualified Distribution.Solver.Types.ComponentDeps as CD
 133 import Distribution.Solver.Types.ConstraintSource
 134 import Distribution.Solver.Types.LabeledPackageConstraint
 135 import Distribution.Solver.Types.OptionalStanza
 136 import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex
 137 import Distribution.Solver.Types.PkgConfigDb
 138   ( PkgConfigDb
 139   , readPkgConfigDb
 140   )
 141 import Distribution.Solver.Types.Settings
 142 import Distribution.Solver.Types.SourcePackage as SourcePackage
 143
 144 import Distribution.Client.Utils
 145   ( MergeResult (..)
 146   , ProgressPhase (..)
 147   , determineNumJobs
 148   , logDirChange
 149   , mergeBy
 150   , progressMessage
 151   )
 152 import Distribution.Package
 153   ( HasMungedPackageId (..)
 154   , HasUnitId (..)
 155   , Package (..)
 156   , PackageId
 157   , PackageIdentifier (..)
 158   , UnitId
 159   , packageName
 160   , packageVersion
 161   )
 162 import Distribution.PackageDescription
 163   ( GenericPackageDescription (..)
 164   , PackageDescription
 165   )
 166 import qualified Distribution.PackageDescription as PackageDescription
 167 import Distribution.PackageDescription.Configuration
 168   ( finalizePD
 169   )
 170 import Distribution.Simple.BuildPaths (exeExtension)
 171 import Distribution.Simple.Compiler
 172   ( Compiler (compilerId)
 173   , CompilerId (..)
 174   , CompilerInfo (..)
 175   , PackageDB (..)
 176   , PackageDBStack
 177   , compilerFlavor
 178   , compilerInfo
 179   )
 180 import Distribution.Simple.Configure (interpretPackageDbFlags)
 181 import Distribution.Simple.Errors
 182 import Distribution.Simple.InstallDirs as InstallDirs
 183   ( PathTemplate
 184   , fromPathTemplate
 185   , initialPathTemplateEnv
 186   , installDirsTemplateEnv
 187   , substPathTemplate
 188   , toPathTemplate
 189   )
 190 import qualified Distribution.Simple.InstallDirs as InstallDirs
 191 import Distribution.Simple.PackageIndex (InstalledPackageIndex)
 192 import qualified Distribution.Simple.PackageIndex as PackageIndex
 193 import Distribution.Simple.Program (ProgramDb)
 194 import Distribution.Simple.Register (defaultRegisterOptions, registerPackage)
 195 import Distribution.Simple.Setup
 196   ( BenchmarkFlags
 197   , BuildFlags (..)
 198   , HaddockFlags (..)
 199   , TestFlags
 200   , buildCommand
 201   , defaultDistPref
 202   , emptyBuildFlags
 203   , flagToMaybe
 204   , fromFlag
 205   , fromFlagOrDefault
 206   , haddockCommand
 207   , toFlag
 208   )
 209 import qualified Distribution.Simple.Setup as Cabal
 210   ( CopyFlags (..)
 211   , Flag (..)
 212   , RegisterFlags (..)
 213   , TestFlags (..)
 214   , copyCommand
 215   , emptyCopyFlags
 216   , emptyRegisterFlags
 217   , registerCommand
 218   , testCommand
 219   )
 220 import Distribution.Simple.Utils
 221   ( VerboseException
 222   , createDirectoryIfMissingVerbose
 223   , writeFileAtomic
 224   )
 225 import Distribution.Simple.Utils as Utils
 226   ( debug
 227   , debugNoWrap
 228   , dieWithException
 229   , info
 230   , notice
 231   , warn
 232   , withTempDirectory
 233   )
 234 import Distribution.System
 235   ( OS (Windows)
 236   , Platform
 237   , buildOS
 238   , buildPlatform
 239   )
 240 import Distribution.Types.Flag
 241   ( FlagAssignment
 242   , PackageFlag (..)
 243   , diffFlagAssignment
 244   , mkFlagAssignment
 245   , nullFlagAssignment
 246   , showFlagAssignment
 247   )
 248 import Distribution.Types.GivenComponent
 249   ( GivenComponent (..)
 250   )
 251 import Distribution.Types.MungedPackageId
 252 import Distribution.Types.PackageVersionConstraint
 253   ( PackageVersionConstraint (..)
 254   , thisPackageVersionConstraint
 255   )
 256 import Distribution.Utils.NubList
 257 import Distribution.Verbosity as Verbosity
 258   ( modifyVerbosity
 259   , normal
 260   , verbose
 261   )
 262 import Distribution.Version
 263   ( Version
 264   , VersionRange
 265   , foldVersionRange
 266   )
 267
 268 import qualified Data.ByteString as BS
 269 import Distribution.Client.Errors
 270
 271 -- TODO:
 272
 273 -- * assign flags to packages individually
 274
 275 --   * complain about flags that do not apply to any package given as target
 276 --     so flags do not apply to dependencies, only listed, can use flag
 277 --     constraints for dependencies
 278
 279 -- * allow flag constraints
 280
 281 -- * allow installed constraints
 282
 283 -- * allow flag and installed preferences
 284
 285 --   * allow persistent configure flags for each package individually
 286
 287 -- ------------------------------------------------------------
 288
 289 -- * Top level user actions
 290
 291 -- ------------------------------------------------------------
 292
 293 -- | Installs the packages needed to satisfy a list of dependencies.
 294 install
 295   :: Verbosity
 296   -> PackageDBStack
 297   -> RepoContext
 298   -> Compiler
 299   -> Platform
 300   -> ProgramDb
 301   -> GlobalFlags
 302   -> ConfigFlags
 303   -> ConfigExFlags
 304   -> InstallFlags
 305   -> HaddockFlags
 306   -> TestFlags
 307   -> BenchmarkFlags
 308   -> [UserTarget]
 309   -> IO ()
 310 install
 311   verbosity
 312   packageDBs
 313   repos
 314   comp
 315   platform
 316   progdb
 317   globalFlags
 318   configFlags
 319   configExFlags
 320   installFlags
 321   haddockFlags
 322   testFlags
 323   benchmarkFlags
 324   userTargets0 = do
 325     unless (installRootCmd installFlags == Cabal.NoFlag) $
 326       warn verbosity $
 327         "--root-cmd is no longer supported, "
 328           ++ "see https://github.com/haskell/cabal/issues/3353"
 329           ++ " (if you didn't type --root-cmd, comment out root-cmd"
 330           ++ " in your ~/.config/cabal/config file)"
 331     let userOrSandbox = fromFlag (configUserInstall configFlags)
 332     unless userOrSandbox $
 333       warn verbosity $
 334         "the --global flag is deprecated -- "
 335           ++ "it is generally considered a bad idea to install packages "
 336           ++ "into the global store"
 337
 338     installContext <- makeInstallContext verbosity args (Just userTargets0)
 339     planResult <-
 340       foldProgress logMsg (return . Left) (return . Right)
 341         =<< makeInstallPlan verbosity args installContext
 342
 343     case planResult of
 344       Left message -> do
 345         reportPlanningFailure verbosity args installContext message
 346         die'' $ ReportPlanningFailure message
 347       Right installPlan ->
 348         processInstallPlan verbosity args installContext installPlan
 349     where
 350       args :: InstallArgs
 351       args =
 352         ( packageDBs
 353         , repos
 354         , comp
 355         , platform
 356         , progdb
 357         , globalFlags
 358         , configFlags
 359         , configExFlags
 360         , installFlags
 361         , haddockFlags
 362         , testFlags
 363         , benchmarkFlags
 364         )
 365
 366       die'' = dieWithException verbosity
 367
 368       logMsg message rest = debugNoWrap verbosity message >> rest
 369
 370 -- TODO: Make InstallContext a proper data type with documented fields.
 371
 372 -- | Common context for makeInstallPlan and processInstallPlan.
 373 type InstallContext =
 374   ( InstalledPackageIndex
 375   , SourcePackageDb
 376   , PkgConfigDb
 377   , [UserTarget]
 378   , [PackageSpecifier UnresolvedSourcePackage]
 379   , HttpTransport
 380   )
 381
 382 -- TODO: Make InstallArgs a proper data type with documented fields or just get
 383 -- rid of it completely.
 384
 385 -- | Initial arguments given to 'install' or 'makeInstallContext'.
 386 type InstallArgs =
 387   ( PackageDBStack
 388   , RepoContext
 389   , Compiler
 390   , Platform
 391   , ProgramDb
 392   , GlobalFlags
 393   , ConfigFlags
 394   , ConfigExFlags
 395   , InstallFlags
 396   , HaddockFlags
 397   , TestFlags
 398   , BenchmarkFlags
 399   )
 400
 401 -- | Make an install context given install arguments.
 402 makeInstallContext
 403   :: Verbosity
 404   -> InstallArgs
 405   -> Maybe [UserTarget]
 406   -> IO InstallContext
 407 makeInstallContext
 408   verbosity
 409   ( packageDBs
 410     , repoCtxt
 411     , comp
 412     , _
 413     , progdb
 414     , _
 415     , _
 416     , configExFlags
 417     , installFlags
 418     , _
 419     , _
 420     , _
 421     )
 422   mUserTargets = do
 423     let idxState = flagToMaybe (installIndexState installFlags)
 424
 425     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
 426     (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing
 427     pkgConfigDb <- readPkgConfigDb verbosity progdb
 428
 429     checkConfigExFlags
 430       verbosity
 431       installedPkgIndex
 432       (packageIndex sourcePkgDb)
 433       configExFlags
 434     transport <- repoContextGetTransport repoCtxt
 435
 436     (userTargets, pkgSpecifiers) <- case mUserTargets of
 437       Nothing ->
 438         -- We want to distinguish between the case where the user has given an
 439         -- empty list of targets on the command-line and the case where we
 440         -- specifically want to have an empty list of targets.
 441         return ([], [])
 442       Just userTargets0 -> do
 443         -- For install, if no target is given it means we use the current
 444         -- directory as the single target.
 445         let userTargets
 446               | null userTargets0 = [UserTargetLocalDir "."]
 447               | otherwise = userTargets0
 448
 449         pkgSpecifiers <-
 450           resolveUserTargets
 451             verbosity
 452             repoCtxt
 453             (packageIndex sourcePkgDb)
 454             userTargets
 455         return (userTargets, pkgSpecifiers)
 456
 457     return
 458       ( installedPkgIndex
 459       , sourcePkgDb
 460       , pkgConfigDb
 461       , userTargets
 462       , pkgSpecifiers
 463       , transport
 464       )
 465
 466 -- | Make an install plan given install context and install arguments.
 467 makeInstallPlan
 468   :: Verbosity
 469   -> InstallArgs
 470   -> InstallContext
 471   -> IO (Progress String String SolverInstallPlan)
 472 makeInstallPlan
 473   verbosity
 474   ( _
 475     , _
 476     , comp
 477     , platform
 478     , _
 479     , _
 480     , configFlags
 481     , configExFlags
 482     , installFlags
 483     , _
 484     , _
 485     , _
 486     )
 487   ( installedPkgIndex
 488     , sourcePkgDb
 489     , pkgConfigDb
 490     , _
 491     , pkgSpecifiers
 492     , _
 493     ) = do
 494     notice verbosity "Resolving dependencies..."
 495     return $
 496       planPackages
 497         verbosity
 498         comp
 499         platform
 500         configFlags
 501         configExFlags
 502         installFlags
 503         installedPkgIndex
 504         sourcePkgDb
 505         pkgConfigDb
 506         pkgSpecifiers
 507
 508 -- | Given an install plan, perform the actual installations.
 509 processInstallPlan
 510   :: Verbosity
 511   -> InstallArgs
 512   -> InstallContext
 513   -> SolverInstallPlan
 514   -> IO ()
 515 processInstallPlan
 516   verbosity
 517   args@(_, _, _, _, _, _, configFlags, _, installFlags, _, _, _)
 518   ( installedPkgIndex
 519     , sourcePkgDb
 520     , _
 521     , userTargets
 522     , pkgSpecifiers
 523     , _
 524     )
 525   installPlan0 = do
 526     checkPrintPlan
 527       verbosity
 528       installedPkgIndex
 529       installPlan
 530       sourcePkgDb
 531       installFlags
 532       pkgSpecifiers
 533
 534     unless (dryRun || nothingToInstall) $ do
 535       buildOutcomes <-
 536         performInstallations
 537           verbosity
 538           args
 539           installedPkgIndex
 540           installPlan
 541       postInstallActions verbosity args userTargets installPlan buildOutcomes
 542     where
 543       installPlan = InstallPlan.configureInstallPlan configFlags installPlan0
 544       dryRun = fromFlag (installDryRun installFlags)
 545       nothingToInstall = null (fst (InstallPlan.ready installPlan))
 546
 547 -- ------------------------------------------------------------
 548
 549 -- * Installation planning
 550
 551 -- ------------------------------------------------------------
 552
 553 planPackages
 554   :: Verbosity
 555   -> Compiler
 556   -> Platform
 557   -> ConfigFlags
 558   -> ConfigExFlags
 559   -> InstallFlags
 560   -> InstalledPackageIndex
 561   -> SourcePackageDb
 562   -> PkgConfigDb
 563   -> [PackageSpecifier UnresolvedSourcePackage]
 564   -> Progress String String SolverInstallPlan
 565 planPackages
 566   verbosity
 567   comp
 568   platform
 569   configFlags
 570   configExFlags
 571   installFlags
 572   installedPkgIndex
 573   sourcePkgDb
 574   pkgConfigDb
 575   pkgSpecifiers =
 576     resolveDependencies
 577       platform
 578       (compilerInfo comp)
 579       pkgConfigDb
 580       resolverParams
 581       >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return
 582     where
 583       resolverParams =
 584         setMaxBackjumps
 585           ( if maxBackjumps < 0
 586               then Nothing
 587               else Just maxBackjumps
 588           )
 589           . setIndependentGoals independentGoals
 590           . setReorderGoals reorderGoals
 591           . setCountConflicts countConflicts
 592           . setFineGrainedConflicts fineGrainedConflicts
 593           . setMinimizeConflictSet minimizeConflictSet
 594           . setAvoidReinstalls avoidReinstalls
 595           . setShadowPkgs shadowPkgs
 596           . setStrongFlags strongFlags
 597           . setAllowBootLibInstalls allowBootLibInstalls
 598           . setOnlyConstrained onlyConstrained
 599           . setSolverVerbosity verbosity
 600           . setPreferenceDefault
 601             ( if upgradeDeps
 602                 then PreferAllLatest
 603                 else PreferLatestForSelected
 604             )
 605           . removeLowerBounds allowOlder
 606           . removeUpperBounds allowNewer
 607           . addPreferences
 608             -- preferences from the config file or command line
 609             [ PackageVersionPreference name ver
 610             | PackageVersionConstraint name ver <- configPreferences configExFlags
 611             ]
 612           . addConstraints
 613             -- version constraints from the config file or command line
 614             [ LabeledPackageConstraint (userToPackageConstraint pc) src
 615             | (pc, src) <- configExConstraints configExFlags
 616             ]
 617           . addConstraints
 618             -- FIXME: this just applies all flags to all targets which
 619             -- is silly. We should check if the flags are appropriate
 620             [ let pc =
 621                     PackageConstraint
 622                       (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
 623                       (PackagePropertyFlags flags)
 624                in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
 625             | let flags = configConfigurationsFlags configFlags
 626             , not (nullFlagAssignment flags)
 627             , pkgSpecifier <- pkgSpecifiers
 628             ]
 629           . addConstraints
 630             [ let pc =
 631                     PackageConstraint
 632                       (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
 633                       (PackagePropertyStanzas stanzas)
 634                in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
 635             | pkgSpecifier <- pkgSpecifiers
 636             ]
 637           . (if reinstall then reinstallTargets else id)
 638           -- Don't solve for executables, the legacy install codepath
 639           -- doesn't understand how to install them
 640           . setSolveExecutables (SolveExecutables False)
 641           $ standardInstallPolicy
 642             installedPkgIndex
 643             sourcePkgDb
 644             pkgSpecifiers
 645
 646       stanzas =
 647         [TestStanzas | testsEnabled]
 648           ++ [BenchStanzas | benchmarksEnabled]
 649       testsEnabled = fromFlagOrDefault False $ configTests configFlags
 650       benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags
 651
 652       reinstall =
 653         fromFlag (installOverrideReinstall installFlags)
 654           || fromFlag (installReinstall installFlags)
 655       reorderGoals = fromFlag (installReorderGoals installFlags)
 656       countConflicts = fromFlag (installCountConflicts installFlags)
 657       fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags)
 658       minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags)
 659       independentGoals = fromFlag (installIndependentGoals installFlags)
 660       avoidReinstalls = fromFlag (installAvoidReinstalls installFlags)
 661       shadowPkgs = fromFlag (installShadowPkgs installFlags)
 662       strongFlags = fromFlag (installStrongFlags installFlags)
 663       maxBackjumps = fromFlag (installMaxBackjumps installFlags)
 664       allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags)
 665       onlyConstrained = fromFlag (installOnlyConstrained installFlags)
 666       upgradeDeps = fromFlag (installUpgradeDeps installFlags)
 667       onlyDeps = fromFlag (installOnlyDeps installFlags)
 668
 669       allowOlder =
 670         fromMaybe
 671           (AllowOlder mempty)
 672           (configAllowOlder configExFlags)
 673       allowNewer =
 674         fromMaybe
 675           (AllowNewer mempty)
 676           (configAllowNewer configExFlags)
 677
 678 -- | Remove the provided targets from the install plan.
 679 pruneInstallPlan
 680   :: Package targetpkg
 681   => [PackageSpecifier targetpkg]
 682   -> SolverInstallPlan
 683   -> Progress String String SolverInstallPlan
 684 pruneInstallPlan pkgSpecifiers =
 685   -- TODO: this is a general feature and should be moved to D.C.Dependency
 686   -- Also, the InstallPlan.remove should return info more precise to the
 687   -- problem, rather than the very general PlanProblem type.
 688   either (Fail . explain) Done
 689     . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)
 690   where
 691     explain :: [SolverInstallPlan.SolverPlanProblem] -> String
 692     explain problems =
 693       "Cannot select only the dependencies (as requested by the "
 694         ++ "'--only-dependencies' flag), "
 695         ++ ( case pkgids of
 696               [pkgid] -> "the package " ++ prettyShow pkgid ++ " is "
 697               _ ->
 698                 "the packages "
 699                   ++ intercalate ", " (map prettyShow pkgids)
 700                   ++ " are "
 701            )
 702         ++ "required by a dependency of one of the other targets."
 703       where
 704         pkgids =
 705           nub
 706             [ depid
 707             | SolverInstallPlan.PackageMissingDeps _ depids <- problems
 708             , depid <- depids
 709             , packageName depid `elem` targetnames
 710             ]
 711
 712     targetnames = map pkgSpecifierTarget pkgSpecifiers
 713
 714 -- ------------------------------------------------------------
 715
 716 -- * Informational messages
 717
 718 -- ------------------------------------------------------------
 719
 720 -- | Perform post-solver checks of the install plan and print it if
 721 -- either requested or needed.
 722 checkPrintPlan
 723   :: Verbosity
 724   -> InstalledPackageIndex
 725   -> InstallPlan
 726   -> SourcePackageDb
 727   -> InstallFlags
 728   -> [PackageSpecifier UnresolvedSourcePackage]
 729   -> IO ()
 730 checkPrintPlan
 731   verbosity
 732   installed
 733   installPlan
 734   sourcePkgDb
 735   installFlags
 736   pkgSpecifiers = do
 737     -- User targets that are already installed.
 738     let preExistingTargets =
 739           [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers, InstallPlan.PreExisting p <- InstallPlan.toList installPlan, packageName p `elem` tgts
 740           ]
 741
 742     -- If there's nothing to install, we print the already existing
 743     -- target packages as an explanation.
 744     when nothingToInstall $
 745       notice verbosity $
 746         unlines $
 747           "All the requested packages are already installed:"
 748             : map (prettyShow . packageId) preExistingTargets
 749             ++ ["Use --reinstall if you want to reinstall anyway."]
 750
 751     let lPlan =
 752           [ (pkg, status)
 753           | pkg <- InstallPlan.executionOrder installPlan
 754           , let status = packageStatus installed pkg
 755           ]
 756     -- Are any packages classified as reinstalls?
 757     let reinstalledPkgs =
 758           [ ipkg
 759           | (_pkg, status) <- lPlan
 760           , ipkg <- extractReinstalls status
 761           ]
 762     -- Packages that are already broken.
 763     let oldBrokenPkgs =
 764           map Installed.installedUnitId
 765             . PackageIndex.reverseDependencyClosure installed
 766             . map (Installed.installedUnitId . fst)
 767             . PackageIndex.brokenPackages
 768             $ installed
 769     let excluded = reinstalledPkgs ++ oldBrokenPkgs
 770     -- Packages that are reverse dependencies of replaced packages are very
 771     -- likely to be broken. We exclude packages that are already broken.
 772     let newBrokenPkgs =
 773           filter
 774             (\p -> not (Installed.installedUnitId p `elem` excluded))
 775             (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)
 776     let containsReinstalls = not (null reinstalledPkgs)
 777     let breaksPkgs = not (null newBrokenPkgs)
 778
 779     let adaptedVerbosity
 780           | containsReinstalls
 781           , not overrideReinstall =
 782               modifyVerbosity (max verbose) verbosity
 783           | otherwise = verbosity
 784
 785     -- We print the install plan if we are in a dry-run or if we are confronted
 786     -- with a dangerous install plan.
 787     when (dryRun || containsReinstalls && not overrideReinstall) $
 788       printPlan
 789         (dryRun || breaksPkgs && not overrideReinstall)
 790         adaptedVerbosity
 791         lPlan
 792         sourcePkgDb
 793
 794     -- If the install plan is dangerous, we print various warning messages. In
 795     -- particular, if we can see that packages are likely to be broken, we even
 796     -- bail out (unless installation has been forced with --force-reinstalls).
 797     when containsReinstalls $ do
 798       let errorStr =
 799             unlines $
 800               "The following packages are likely to be broken by the reinstalls:"
 801                 : map (prettyShow . mungedId) newBrokenPkgs
 802                 ++ if overrideReinstall
 803                   then
 804                     if dryRun
 805                       then []
 806                       else
 807                         [ "Continuing even though "
 808                             ++ "the plan contains dangerous reinstalls."
 809                         ]
 810                   else ["Use --force-reinstalls if you want to install anyway."]
 811       if breaksPkgs
 812         then do
 813           ( if dryRun || overrideReinstall
 814               then warn verbosity errorStr
 815               else dieWithException verbosity $ BrokenException errorStr
 816             )
 817         else
 818           unless dryRun $
 819             warn
 820               verbosity
 821               "Note that reinstalls are always dangerous. Continuing anyway..."
 822
 823     -- If we are explicitly told to not download anything, check that all packages
 824     -- are already fetched.
 825     let offline = fromFlagOrDefault False (installOfflineMode installFlags)
 826     when offline $ do
 827       let pkgs =
 828             [ confPkgSource cpkg
 829             | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan
 830             ]
 831       notFetched <-
 832         fmap (map packageId)
 833           . filterM (fmap isNothing . checkFetched . srcpkgSource)
 834           $ pkgs
 835       unless (null notFetched) $
 836         dieWithException verbosity $
 837           Can'tDownloadPackagesOffline (map prettyShow notFetched)
 838     where
 839       nothingToInstall = null (fst (InstallPlan.ready installPlan))
 840
 841       dryRun = fromFlag (installDryRun installFlags)
 842       overrideReinstall = fromFlag (installOverrideReinstall installFlags)
 843
 844 data PackageStatus
 845   = NewPackage
 846   | NewVersion [Version]
 847   | Reinstall [UnitId] [PackageChange]
 848
 849 type PackageChange = MergeResult MungedPackageId MungedPackageId
 850
 851 extractReinstalls :: PackageStatus -> [UnitId]
 852 extractReinstalls (Reinstall ipids _) = ipids
 853 extractReinstalls _ = []
 854
 855 packageStatus
 856   :: InstalledPackageIndex
 857   -> ReadyPackage
 858   -> PackageStatus
 859 packageStatus installedPkgIndex cpkg =
 860   case PackageIndex.lookupPackageName
 861     installedPkgIndex
 862     (packageName cpkg) of
 863     [] -> NewPackage
 864     ps -> case filter
 865       ( (== mungedId cpkg)
 866           . mungedId
 867       )
 868       (concatMap snd ps) of
 869       [] -> NewVersion (map fst ps)
 870       pkgs@(pkg : _) ->
 871         Reinstall
 872           (map Installed.installedUnitId pkgs)
 873           (changes pkg cpkg)
 874   where
 875     changes
 876       :: Installed.InstalledPackageInfo
 877       -> ReadyPackage
 878       -> [PackageChange]
 879     changes pkg (ReadyPackage pkg') =
 880       filter changed $
 881         mergeBy
 882           (comparing mungedName)
 883           -- deps of installed pkg
 884           (resolveInstalledIds $ Installed.depends pkg)
 885           -- deps of configured pkg
 886           (resolveInstalledIds $ CD.nonSetupDeps (depends pkg'))
 887
 888     -- convert to source pkg ids via index
 889     resolveInstalledIds :: [UnitId] -> [MungedPackageId]
 890     resolveInstalledIds =
 891       nub
 892         . sort
 893         . map mungedId
 894         . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex)
 895
 896     changed (InBoth pkgid pkgid') = pkgid /= pkgid'
 897     changed _ = True
 898
 899 printPlan
 900   :: Bool -- is dry run
 901   -> Verbosity
 902   -> [(ReadyPackage, PackageStatus)]
 903   -> SourcePackageDb
 904   -> IO ()
 905 printPlan dryRun verbosity plan sourcePkgDb = case plan of
 906   [] -> return ()
 907   pkgs
 908     | verbosity >= Verbosity.verbose ->
 909         notice verbosity $
 910           unlines $
 911             ("In order, the following " ++ wouldWill ++ " be installed:")
 912               : map showPkgAndReason pkgs
 913     | otherwise ->
 914         notice verbosity $
 915           unlines $
 916             ( "In order, the following "
 917                 ++ wouldWill
 918                 ++ " be installed (use -v for more details):"
 919             )
 920               : map showPkg pkgs
 921   where
 922     wouldWill
 923       | dryRun = "would"
 924       | otherwise = "will"
 925
 926     showPkg (pkg, _) =
 927       prettyShow (packageId pkg)
 928         ++ showLatest (pkg)
 929
 930     showPkgAndReason (ReadyPackage pkg', pr) =
 931       unwords
 932         [ prettyShow (packageId pkg')
 933         , showLatest pkg'
 934         , showFlagAssignment (nonDefaultFlags pkg')
 935         , showStanzas (confPkgStanzas pkg')
 936         , showDep pkg'
 937         , case pr of
 938             NewPackage -> "(new package)"
 939             NewVersion _ -> "(new version)"
 940             Reinstall _ cs ->
 941               "(reinstall)" ++ case cs of
 942                 [] -> ""
 943                 diff ->
 944                   "(changes: "
 945                     ++ intercalate ", " (map change diff)
 946                     ++ ")"
 947         ]
 948
 949     showLatest :: Package srcpkg => srcpkg -> String
 950     showLatest pkg = case mLatestVersion of
 951       Just latestVersion ->
 952         if packageVersion pkg < latestVersion
 953           then ("(latest: " ++ prettyShow latestVersion ++ ")")
 954           else ""
 955       Nothing -> ""
 956       where
 957         mLatestVersion :: Maybe Version
 958         mLatestVersion =
 959           fmap packageVersion $
 960             safeLast $
 961               SourcePackageIndex.lookupPackageName
 962                 (packageIndex sourcePkgDb)
 963                 (packageName pkg)
 964
 965     toFlagAssignment :: [PackageFlag] -> FlagAssignment
 966     toFlagAssignment = mkFlagAssignment . map (\f -> (flagName f, flagDefault f))
 967
 968     nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment
 969     nonDefaultFlags cpkg =
 970       let defaultAssignment =
 971             toFlagAssignment
 972               ( genPackageFlags
 973                   ( SourcePackage.srcpkgDescription $
 974                       confPkgSource cpkg
 975                   )
 976               )
 977        in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment
 978
 979     change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed"
 980     change (InBoth pkgid pkgid') =
 981       prettyShow pkgid
 982         ++ " -> "
 983         ++ prettyShow (mungedVersion pkgid')
 984     change (OnlyInRight pkgid') = prettyShow pkgid' ++ " added"
 985
 986     showDep pkg
 987       | Just rdeps <- Map.lookup (packageId pkg) revDeps =
 988           " (via: " ++ unwords (map prettyShow rdeps) ++ ")"
 989       | otherwise = ""
 990
 991     revDepGraphEdges :: [(PackageId, PackageId)]
 992     revDepGraphEdges =
 993       [ (rpid, packageId cpkg)
 994       | (ReadyPackage cpkg, _) <- plan
 995       , ConfiguredId
 996           rpid
 997           ( Just
 998               ( PackageDescription.CLibName
 999                   PackageDescription.LMainLibName
1000                 )
1001             )
1002           _ <-
1003           CD.flatDeps (confPkgDeps cpkg)
1004       ]
1005
1006     revDeps :: Map.Map PackageId [PackageId]
1007     revDeps = Map.fromListWith (++) (map (fmap (: [])) revDepGraphEdges)
1008
1009 -- ------------------------------------------------------------
1010
1011 -- * Post installation stuff
1012
1013 -- ------------------------------------------------------------
1014
1015 -- | Report a solver failure. This works slightly differently to
1016 -- 'postInstallActions', as (by definition) we don't have an install plan.
1017 reportPlanningFailure
1018   :: Verbosity
1019   -> InstallArgs
1020   -> InstallContext
1021   -> String
1022   -> IO ()
1023 reportPlanningFailure
1024   verbosity
1025   ( _
1026     , _
1027     , comp
1028     , platform
1029     , _
1030     , _
1031     , configFlags
1032     , _
1033     , installFlags
1034     , _
1035     , _
1036     , _
1037     )
1038   (_, sourcePkgDb, _, _, pkgSpecifiers, _)
1039   message = do
1040     when reportFailure $ do
1041       -- Only create reports for explicitly named packages
1042       let pkgids =
1043             filter
1044               (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb))
1045               $ mapMaybe theSpecifiedPackage pkgSpecifiers
1046
1047           buildReports =
1048             BuildReports.fromPlanningFailure
1049               platform
1050               (compilerId comp)
1051               pkgids
1052               (configConfigurationsFlags configFlags)
1053
1054       unless (null buildReports) $
1055         info verbosity $
1056           "Solver failure will be reported for "
1057             ++ intercalate "," (map prettyShow pkgids)
1058
1059       -- Save reports
1060       BuildReports.storeLocal
1061         (compilerInfo comp)
1062         (fromNubList $ installSummaryFile installFlags)
1063         buildReports
1064         platform
1065
1066       -- Save solver log
1067       case logFile of
1068         Nothing -> return ()
1069         Just template -> for_ pkgids $ \pkgid ->
1070           let env =
1071                 initialPathTemplateEnv
1072                   pkgid
1073                   dummyIpid
1074                   (compilerInfo comp)
1075                   platform
1076               path = fromPathTemplate $ substPathTemplate env template
1077            in writeFile path message
1078     where
1079       reportFailure = fromFlag (installReportPlanningFailure installFlags)
1080       logFile = flagToMaybe (installLogFile installFlags)
1081
1082       -- A IPID is calculated from the transitive closure of
1083       -- dependencies, but when the solver fails we don't have that.
1084       -- So we fail.
1085       dummyIpid = error "reportPlanningFailure: installed package ID not available"
1086
1087 -- | If a 'PackageSpecifier' refers to a single package, return Just that
1088 -- package.
1089 theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId
1090 theSpecifiedPackage pkgSpec =
1091   case pkgSpec of
1092     NamedPackage name [PackagePropertyVersion version] ->
1093       PackageIdentifier name <$> trivialRange version
1094     NamedPackage _ _ -> Nothing
1095     SpecificSourcePackage pkg -> Just $ packageId pkg
1096   where
1097     -- \| If a range includes only a single version, return Just that version.
1098     trivialRange :: VersionRange -> Maybe Version
1099     trivialRange =
1100       foldVersionRange
1101         Nothing
1102         Just -- "== v"
1103         (\_ -> Nothing)
1104         (\_ -> Nothing)
1105         (\_ _ -> Nothing)
1106         (\_ _ -> Nothing)
1107
1108 -- | Various stuff we do after successful or unsuccessfully installing a bunch
1109 -- of packages. This includes:
1110 --
1111 --  * build reporting, local and remote
1112 --  * symlinking binaries
1113 --  * updating indexes
1114 --  * error reporting
1115 postInstallActions
1116   :: Verbosity
1117   -> InstallArgs
1118   -> [UserTarget]
1119   -> InstallPlan
1120   -> BuildOutcomes
1121   -> IO ()
1122 postInstallActions
1123   verbosity
1124   ( packageDBs
1125     , _
1126     , comp
1127     , platform
1128     , progdb
1129     , globalFlags
1130     , configFlags
1131     , _
1132     , installFlags
1133     , _
1134     , _
1135     , _
1136     )
1137   _
1138   installPlan
1139   buildOutcomes = do
1140     let buildReports =
1141           BuildReports.fromInstallPlan
1142             platform
1143             (compilerId comp)
1144             installPlan
1145             buildOutcomes
1146     BuildReports.storeLocal
1147       (compilerInfo comp)
1148       (fromNubList $ installSummaryFile installFlags)
1149       buildReports
1150       platform
1151     when (reportingLevel >= AnonymousReports) $
1152       BuildReports.storeAnonymous buildReports
1153     when (reportingLevel == DetailedReports) $
1154       storeDetailedBuildReports verbosity logsDir buildReports
1155
1156     regenerateHaddockIndex
1157       verbosity
1158       packageDBs
1159       comp
1160       platform
1161       progdb
1162       configFlags
1163       installFlags
1164       buildOutcomes
1165
1166     symlinkBinaries
1167       verbosity
1168       platform
1169       comp
1170       configFlags
1171       installFlags
1172       installPlan
1173       buildOutcomes
1174
1175     printBuildFailures verbosity buildOutcomes
1176     where
1177       reportingLevel = fromFlag (installBuildReports installFlags)
1178       logsDir = fromFlag (globalLogsDir globalFlags)
1179
1180 storeDetailedBuildReports
1181   :: Verbosity
1182   -> FilePath
1183   -> [(BuildReports.BuildReport, Maybe Repo)]
1184   -> IO ()
1185 storeDetailedBuildReports verbosity logsDir reports =
1186   sequence_
1187     [ do
1188       allReportsDir <- defaultReportsDir
1189       let logFileName = prettyShow (BuildReports.package report) <.> "log"
1190           logFile = logsDir </> logFileName
1191           reportsDir = allReportsDir </> unRepoName (remoteRepoName remoteRepo)
1192           reportFile = reportsDir </> logFileName
1193
1194       handleMissingLogFile $ do
1195         buildLog <- readFile logFile
1196         createDirectoryIfMissing True reportsDir -- FIXME
1197         writeFile reportFile (show (showBuildReport report, buildLog))
1198     | (report, Just repo) <- reports
1199     , Just remoteRepo <- [maybeRepoRemote repo]
1200     , isLikelyToHaveLogFile (BuildReports.installOutcome report)
1201     ]
1202   where
1203     isLikelyToHaveLogFile BuildReports.ConfigureFailed{} = True
1204     isLikelyToHaveLogFile BuildReports.BuildFailed{} = True
1205     isLikelyToHaveLogFile BuildReports.InstallFailed{} = True
1206     isLikelyToHaveLogFile BuildReports.InstallOk{} = True
1207     isLikelyToHaveLogFile _ = False
1208
1209     handleMissingLogFile = Exception.handleJust missingFile $ \ioe ->
1210       warn verbosity $
1211         "Missing log file for build report: "
1212           ++ fromMaybe "" (ioeGetFileName ioe)
1213
1214     missingFile ioe
1215       | isDoesNotExistError ioe = Just ioe
1216     missingFile _ = Nothing
1217
1218 regenerateHaddockIndex
1219   :: Verbosity
1220   -> [PackageDB]
1221   -> Compiler
1222   -> Platform
1223   -> ProgramDb
1224   -> ConfigFlags
1225   -> InstallFlags
1226   -> BuildOutcomes
1227   -> IO ()
1228 regenerateHaddockIndex
1229   verbosity
1230   packageDBs
1231   comp
1232   platform
1233   progdb
1234   configFlags
1235   installFlags
1236   buildOutcomes
1237     | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do
1238         defaultDirs <-
1239           InstallDirs.defaultInstallDirs
1240             (compilerFlavor comp)
1241             (fromFlag (configUserInstall configFlags))
1242             True
1243         let indexFileTemplate = fromFlag (installHaddockIndex installFlags)
1244             indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate
1245
1246         notice verbosity $
1247           "Updating documentation index " ++ indexFile
1248
1249         -- TODO: might be nice if the install plan gave us the new InstalledPackageInfo
1250         installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
1251         Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile
1252     | otherwise = return ()
1253     where
1254       haddockIndexFileIsRequested =
1255         fromFlag (installDocumentation installFlags)
1256           && isJust (flagToMaybe (installHaddockIndex installFlags))
1257
1258       -- We want to regenerate the index if some new documentation was actually
1259       -- installed. Since the index can be only per-user or per-sandbox (see
1260       -- #1337), we don't do it for global installs or special cases where we're
1261       -- installing into a specific db.
1262       shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes
1263         where
1264           someDocsWereInstalled = any installedDocs . Map.elems
1265           installedDocs (Right (BuildResult DocsOk _ _)) = True
1266           installedDocs _ = False
1267
1268           normalUserInstall =
1269             (UserPackageDB `elem` packageDBs)
1270               && all (not . isSpecificPackageDB) packageDBs
1271           isSpecificPackageDB (SpecificPackageDB _) = True
1272           isSpecificPackageDB _ = False
1273
1274       substHaddockIndexFileName defaultDirs =
1275         fromPathTemplate
1276           . substPathTemplate env
1277         where
1278           env = env0 ++ installDirsTemplateEnv absoluteDirs
1279           env0 =
1280             InstallDirs.compilerTemplateEnv (compilerInfo comp)
1281               ++ InstallDirs.platformTemplateEnv platform
1282               ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform
1283           absoluteDirs =
1284             InstallDirs.substituteInstallDirTemplates
1285               env0
1286               templateDirs
1287           templateDirs =
1288             InstallDirs.combineInstallDirs
1289               fromFlagOrDefault
1290               defaultDirs
1291               (configInstallDirs configFlags)
1292
1293 symlinkBinaries
1294   :: Verbosity
1295   -> Platform
1296   -> Compiler
1297   -> ConfigFlags
1298   -> InstallFlags
1299   -> InstallPlan
1300   -> BuildOutcomes
1301   -> IO ()
1302 symlinkBinaries
1303   verbosity
1304   platform
1305   comp
1306   configFlags
1307   installFlags
1308   plan
1309   buildOutcomes = do
1310     failed <-
1311       InstallSymlink.symlinkBinaries
1312         platform
1313         comp
1314         NeverOverwrite
1315         configFlags
1316         installFlags
1317         plan
1318         buildOutcomes
1319     case failed of
1320       [] -> return ()
1321       [(_, exe, path)] ->
1322         warn verbosity $
1323           "could not create a symlink in "
1324             ++ bindir
1325             ++ " for "
1326             ++ prettyShow exe
1327             ++ " because the file exists there already but is not "
1328             ++ "managed by cabal. You can create a symlink for this executable "
1329             ++ "manually if you wish. The executable file has been installed at "
1330             ++ path
1331       exes ->
1332         warn verbosity $
1333           "could not create symlinks in "
1334             ++ bindir
1335             ++ " for "
1336             ++ intercalate ", " [prettyShow exe | (_, exe, _) <- exes]
1337             ++ " because the files exist there already and are not "
1338             ++ "managed by cabal. You can create symlinks for these executables "
1339             ++ "manually if you wish. The executable files have been installed at "
1340             ++ intercalate ", " [path | (_, _, path) <- exes]
1341     where
1342       bindir = fromFlag (installSymlinkBinDir installFlags)
1343
1344 printBuildFailures :: Verbosity -> BuildOutcomes -> IO ()
1345 printBuildFailures verbosity buildOutcomes =
1346   case [ (pkgid, failure)
1347        | (pkgid, Left failure) <- Map.toList buildOutcomes
1348        ] of
1349     [] -> return ()
1350     failed ->
1351       dieWithException verbosity $
1352         SomePackagesFailedToInstall $
1353           map (\(pkgid, reason) -> (prettyShow pkgid, printFailureReason reason)) failed
1354   where
1355     printFailureReason reason = case reason of
1356       GracefulFailure msg -> msg
1357       DependentFailed pkgid ->
1358         " depends on "
1359           ++ prettyShow pkgid
1360           ++ " which failed to install."
1361       DownloadFailed e ->
1362         " failed while downloading the package."
1363           ++ showException e
1364       UnpackFailed e ->
1365         " failed while unpacking the package."
1366           ++ showException e
1367       ConfigureFailed e ->
1368         " failed during the configure step."
1369           ++ showException e
1370       BuildFailed e ->
1371         " failed during the building phase."
1372           ++ showException e
1373       TestsFailed e ->
1374         " failed during the tests phase."
1375           ++ showException e
1376       InstallFailed e ->
1377         " failed during the final install step."
1378           ++ showException e
1379       -- This will never happen, but we include it for completeness
1380       PlanningFailed -> " failed during the planning phase."
1381
1382     showException e = " The exception was:\n  " ++ show e ++ maybeOOM e
1383 #ifdef mingw32_HOST_OS
1384     maybeOOM _        = ""
1385 #else
1386     maybeOOM e                    = maybe "" onExitFailure (fromException e)
1387     onExitFailure (ExitFailure n)
1388       | n == 9 || n == -9         =
1389       "\nThis may be due to an out-of-memory condition."
1390     onExitFailure _               = ""
1391 #endif
1392
1393 -- ------------------------------------------------------------
1394
1395 -- * Actually do the installations
1396
1397 -- ------------------------------------------------------------
1398
1399 data InstallMisc = InstallMisc
1400   { libVersion :: Maybe Version
1401   }
1402
1403 -- | If logging is enabled, contains location of the log file and the verbosity
1404 -- level for logging.
1405 type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity)
1406
1407 performInstallations
1408   :: Verbosity
1409   -> InstallArgs
1410   -> InstalledPackageIndex
1411   -> InstallPlan
1412   -> IO BuildOutcomes
1413 performInstallations
1414   verbosity
1415   ( packageDBs
1416     , repoCtxt
1417     , comp
1418     , platform
1419     , progdb
1420     , globalFlags
1421     , configFlags
1422     , configExFlags
1423     , installFlags
1424     , haddockFlags
1425     , testFlags
1426     , _
1427     )
1428   installedPkgIndex
1429   installPlan = do
1430     info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "."
1431
1432     jobControl <-
1433       if parallelInstall
1434         then newParallelJobControl numJobs
1435         else newSerialJobControl
1436     fetchLimit <- newJobLimit (min numJobs numFetchJobs)
1437     installLock <- newLock -- serialise installation
1438     cacheLock <- newLock -- serialise access to setup exe cache
1439     executeInstallPlan
1440       verbosity
1441       jobControl
1442       keepGoing
1443       useLogFile
1444       installPlan
1445       $ \rpkg ->
1446         installReadyPackage
1447           platform
1448           cinfo
1449           configFlags
1450           rpkg
1451           $ \configFlags' src pkg pkgoverride ->
1452             fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' ->
1453               installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath ->
1454                 installUnpackedPackage
1455                   verbosity
1456                   installLock
1457                   numJobs
1458                   ( setupScriptOptions
1459                       installedPkgIndex
1460                       cacheLock
1461                       rpkg
1462                   )
1463                   configFlags'
1464                   installFlags
1465                   haddockFlags
1466                   testFlags
1467                   comp
1468                   progdb
1469                   platform
1470                   pkg
1471                   rpkg
1472                   pkgoverride
1473                   mpath
1474                   useLogFile
1475     where
1476       cinfo = compilerInfo comp
1477
1478       numJobs = determineNumJobs (installNumJobs installFlags)
1479       numFetchJobs = 2
1480       parallelInstall = numJobs >= 2
1481       keepGoing = fromFlag (installKeepGoing installFlags)
1482       distPref =
1483         fromFlagOrDefault
1484           (useDistPref defaultSetupScriptOptions)
1485           (configDistPref configFlags)
1486
1487       setupScriptOptions index lock rpkg =
1488         configureSetupScript
1489           packageDBs
1490           comp
1491           platform
1492           progdb
1493           distPref
1494           (chooseCabalVersion configExFlags (libVersion miscOptions))
1495           (Just lock)
1496           parallelInstall
1497           index
1498           (Just rpkg)
1499
1500       reportingLevel = fromFlag (installBuildReports installFlags)
1501       logsDir = fromFlag (globalLogsDir globalFlags)
1502
1503       -- Should the build output be written to a log file instead of stdout?
1504       useLogFile :: UseLogFile
1505       useLogFile =
1506         fmap
1507           ((\f -> (f, loggingVerbosity)) . substLogFileName)
1508           logFileTemplate
1509         where
1510           installLogFile' = flagToMaybe $ installLogFile installFlags
1511           defaultTemplate =
1512             toPathTemplate $
1513               logsDir </> "$compiler" </> "$libname" <.> "log"
1514
1515           -- If the user has specified --remote-build-reporting=detailed, use the
1516           -- default log file location. If the --build-log option is set, use the
1517           -- provided location. Otherwise don't use logging, unless building in
1518           -- parallel (in which case the default location is used).
1519           logFileTemplate :: Maybe PathTemplate
1520           logFileTemplate
1521             | useDefaultTemplate = Just defaultTemplate
1522             | otherwise = installLogFile'
1523
1524           -- If the user has specified --remote-build-reporting=detailed or
1525           -- --build-log, use more verbose logging.
1526           loggingVerbosity :: Verbosity
1527           loggingVerbosity
1528             | overrideVerbosity = modifyVerbosity (max verbose) verbosity
1529             | otherwise = verbosity
1530
1531           useDefaultTemplate :: Bool
1532           useDefaultTemplate
1533             | reportingLevel == DetailedReports = True
1534             | isJust installLogFile' = False
1535             | parallelInstall = True
1536             | otherwise = False
1537
1538           overrideVerbosity :: Bool
1539           overrideVerbosity
1540             | reportingLevel == DetailedReports = True
1541             | isJust installLogFile' = True
1542             | parallelInstall = False
1543             | otherwise = False
1544
1545       substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath
1546       substLogFileName template pkg uid =
1547         fromPathTemplate
1548           . substPathTemplate env
1549           $ template
1550         where
1551           env =
1552             initialPathTemplateEnv
1553               (packageId pkg)
1554               uid
1555               (compilerInfo comp)
1556               platform
1557
1558       miscOptions =
1559         InstallMisc
1560           { libVersion = flagToMaybe (configCabalVersion configExFlags)
1561           }
1562
1563 executeInstallPlan
1564   :: Verbosity
1565   -> JobControl IO (UnitId, BuildOutcome)
1566   -> Bool
1567   -> UseLogFile
1568   -> InstallPlan
1569   -> (ReadyPackage -> IO BuildOutcome)
1570   -> IO BuildOutcomes
1571 executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg =
1572   InstallPlan.execute
1573     jobCtl
1574     keepGoing
1575     depsFailure
1576     plan0
1577     $ \pkg -> do
1578       buildOutcome <- installPkg pkg
1579       printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome
1580       return buildOutcome
1581   where
1582     depsFailure = DependentFailed . packageId
1583
1584     -- Print build log if something went wrong, and 'Installed $PKGID'
1585     -- otherwise.
1586     printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO ()
1587     printBuildResult pkgid uid buildOutcome = case buildOutcome of
1588       (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid)
1589       (Left _) -> do
1590         notice verbosity $ "Failed to install " ++ prettyShow pkgid
1591         when (verbosity >= normal) $
1592           case useLogFile of
1593             Nothing -> return ()
1594             Just (mkLogFileName, _) -> do
1595               let logName = mkLogFileName pkgid uid
1596               putStr $ "Build log ( " ++ logName ++ " ):\n"
1597               printFile logName
1598
1599     printFile :: FilePath -> IO ()
1600     printFile path = readFile path >>= putStr
1601
1602 -- | Call an installer for an 'SourcePackage' but override the configure
1603 -- flags with the ones given by the 'ReadyPackage'. In particular the
1604 -- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly
1605 -- versioned package dependencies. So we ignore any previous partial flag
1606 -- assignment or dependency constraints and use the new ones.
1607 --
1608 -- NB: when updating this function, don't forget to also update
1609 -- 'configurePackage' in D.C.Configure.
1610 installReadyPackage
1611   :: Platform
1612   -> CompilerInfo
1613   -> ConfigFlags
1614   -> ReadyPackage
1615   -> ( ConfigFlags
1616        -> UnresolvedPkgLoc
1617        -> PackageDescription
1618        -> PackageDescriptionOverride
1619        -> a
1620      )
1621   -> a
1622 installReadyPackage
1623   platform
1624   cinfo
1625   configFlags
1626   ( ReadyPackage
1627       ( ConfiguredPackage
1628           ipid
1629           (SourcePackage _ gpkg source pkgoverride)
1630           flags
1631           stanzas
1632           deps
1633         )
1634     )
1635   installPkg =
1636     installPkg
1637       configFlags
1638         { configIPID = toFlag (prettyShow ipid)
1639         , configConfigurationsFlags = flags
1640         , -- We generate the legacy constraints as well as the new style precise deps.
1641           -- In the end only one set gets passed to Setup.hs configure, depending on
1642           -- the Cabal version we are talking to.
1643           configConstraints =
1644             [ thisPackageVersionConstraint srcid
1645             | ConfiguredId
1646                 srcid
1647                 ( Just
1648                     ( PackageDescription.CLibName
1649                         PackageDescription.LMainLibName
1650                       )
1651                   )
1652                 _ipid <-
1653                 CD.nonSetupDeps deps
1654             ]
1655         , configDependencies =
1656             [ GivenComponent (packageName srcid) cname dep_ipid
1657             | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid <-
1658                 CD.nonSetupDeps deps
1659             ]
1660         , -- Use '--exact-configuration' if supported.
1661           configExactConfiguration = toFlag True
1662         , configBenchmarks = toFlag False
1663         , configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas)
1664         }
1665       source
1666       pkg
1667       pkgoverride
1668     where
1669       pkg = case finalizePD
1670         flags
1671         (enableStanzas stanzas)
1672         (const True)
1673         platform
1674         cinfo
1675         []
1676         gpkg of
1677         Left _ -> error "finalizePD ReadyPackage failed"
1678         Right (desc, _) -> desc
1679
1680 fetchSourcePackage
1681   :: Verbosity
1682   -> RepoContext
1683   -> JobLimit
1684   -> UnresolvedPkgLoc
1685   -> (ResolvedPkgLoc -> IO BuildOutcome)
1686   -> IO BuildOutcome
1687 fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do
1688   fetched <- checkFetched src
1689   case fetched of
1690     Just src' -> installPkg src'
1691     Nothing -> onFailure DownloadFailed $ do
1692       loc <-
1693         withJobLimit fetchLimit $
1694           fetchPackage verbosity repoCtxt src
1695       installPkg loc
1696
1697 installLocalPackage
1698   :: Verbosity
1699   -> PackageIdentifier
1700   -> ResolvedPkgLoc
1701   -> FilePath
1702   -> (Maybe FilePath -> IO BuildOutcome)
1703   -> IO BuildOutcome
1704 installLocalPackage verbosity pkgid location distPref installPkg =
1705   case location of
1706     LocalUnpackedPackage dir ->
1707       installPkg (Just dir)
1708     RemoteSourceRepoPackage _repo dir ->
1709       installPkg (Just dir)
1710     LocalTarballPackage tarballPath ->
1711       installLocalTarballPackage
1712         verbosity
1713         pkgid
1714         tarballPath
1715         distPref
1716         installPkg
1717     RemoteTarballPackage _ tarballPath ->
1718       installLocalTarballPackage
1719         verbosity
1720         pkgid
1721         tarballPath
1722         distPref
1723         installPkg
1724     RepoTarballPackage _ _ tarballPath ->
1725       installLocalTarballPackage
1726         verbosity
1727         pkgid
1728         tarballPath
1729         distPref
1730         installPkg
1731
1732 installLocalTarballPackage
1733   :: Verbosity
1734   -> PackageIdentifier
1735   -> FilePath
1736   -> FilePath
1737   -> (Maybe FilePath -> IO BuildOutcome)
1738   -> IO BuildOutcome
1739 installLocalTarballPackage
1740   verbosity
1741   pkgid
1742   tarballPath
1743   distPref
1744   installPkg = do
1745     tmp <- getTemporaryDirectory
1746     withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath ->
1747       onFailure UnpackFailed $ do
1748         let relUnpackedPath = prettyShow pkgid
1749             absUnpackedPath = tmpDirPath </> relUnpackedPath
1750             descFilePath =
1751               absUnpackedPath
1752                 </> prettyShow (packageName pkgid)
1753                 <.> "cabal"
1754         info verbosity $
1755           "Extracting "
1756             ++ tarballPath
1757             ++ " to "
1758             ++ tmpDirPath
1759             ++ "..."
1760         extractTarGzFile tmpDirPath relUnpackedPath tarballPath
1761         exists <- doesFileExist descFilePath
1762         unless exists $
1763           dieWithException verbosity $
1764             PackageDotCabalFileNotFound descFilePath
1765         maybeRenameDistDir absUnpackedPath
1766         installPkg (Just absUnpackedPath)
1767     where
1768       -- 'cabal sdist' puts pre-generated files in the 'dist'
1769       -- directory. This fails when a nonstandard build directory name
1770       -- is used (as is the case with sandboxes), so we need to rename
1771       -- the 'dist' dir here.
1772       --
1773       -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still
1774       -- fails even with this workaround. We probably can live with that.
1775       maybeRenameDistDir :: FilePath -> IO ()
1776       maybeRenameDistDir absUnpackedPath = do
1777         let distDirPath = absUnpackedPath </> defaultDistPref
1778             distDirPathTmp = absUnpackedPath </> (defaultDistPref ++ "-tmp")
1779             distDirPathNew = absUnpackedPath </> distPref
1780         distDirExists <- doesDirectoryExist distDirPath
1781         when
1782           ( distDirExists
1783               && not (distDirPath `equalFilePath` distDirPathNew)
1784           )
1785           $ do
1786             -- NB: we need to handle the case when 'distDirPathNew' is a
1787             -- subdirectory of 'distDirPath' (e.g. the former is
1788             -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist').
1789             debug verbosity $
1790               "Renaming '"
1791                 ++ distDirPath
1792                 ++ "' to '"
1793                 ++ distDirPathTmp
1794                 ++ "'."
1795             renameDirectory distDirPath distDirPathTmp
1796             when (distDirPath `isPrefixOf` distDirPathNew) $
1797               createDirectoryIfMissingVerbose verbosity False distDirPath
1798             debug verbosity $
1799               "Renaming '"
1800                 ++ distDirPathTmp
1801                 ++ "' to '"
1802                 ++ distDirPathNew
1803                 ++ "'."
1804             renameDirectory distDirPathTmp distDirPathNew
1805
1806 installUnpackedPackage
1807   :: Verbosity
1808   -> Lock
1809   -> Int
1810   -> SetupScriptOptions
1811   -> ConfigFlags
1812   -> InstallFlags
1813   -> HaddockFlags
1814   -> TestFlags
1815   -> Compiler
1816   -> ProgramDb
1817   -> Platform
1818   -> PackageDescription
1819   -> ReadyPackage
1820   -> PackageDescriptionOverride
1821   -> Maybe FilePath
1822   -- ^ Directory to change to before starting the installation.
1823   -> UseLogFile
1824   -- ^ File to log output to (if any)
1825   -> IO BuildOutcome
1826 installUnpackedPackage
1827   verbosity
1828   installLock
1829   numJobs
1830   scriptOptions
1831   configFlags
1832   installFlags
1833   haddockFlags
1834   testFlags
1835   comp
1836   progdb
1837   platform
1838   pkg
1839   rpkg
1840   pkgoverride
1841   workingDir
1842   useLogFile = do
1843     -- Override the .cabal file if necessary
1844     case pkgoverride of
1845       Nothing -> return ()
1846       Just pkgtxt -> do
1847         let descFilePath =
1848               fromMaybe "." workingDir
1849                 </> prettyShow (packageName pkgid)
1850                 <.> "cabal"
1851         info verbosity $
1852           "Updating "
1853             ++ prettyShow (packageName pkgid) <.> "cabal"
1854             ++ " with the latest revision from the index."
1855         writeFileAtomic descFilePath pkgtxt
1856
1857     -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if
1858     -- the setup script was compiled against an old version of the Cabal lib).
1859     configFlags' <- addDefaultInstallDirs configFlags
1860     -- Filter out flags not supported by the old versions of the Cabal lib.
1861     let configureFlags :: Version -> ConfigFlags
1862         configureFlags =
1863           filterConfigureFlags
1864             configFlags'
1865               { configVerbosity = toFlag verbosity'
1866               }
1867
1868     -- Path to the optional log file.
1869     mLogPath <- maybeLogPath
1870
1871     logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do
1872       -- Configure phase
1873       onFailure ConfigureFailed $ do
1874         noticeProgress ProgressStarting
1875         setup configureCommand configureFlags mLogPath
1876
1877         -- Build phase
1878         onFailure BuildFailed $ do
1879           noticeProgress ProgressBuilding
1880           setup buildCommand' buildFlags mLogPath
1881
1882           -- Doc generation phase
1883           docsResult <-
1884             if shouldHaddock
1885               then
1886                 ( do
1887                     setup haddockCommand haddockFlags' mLogPath
1888                     return DocsOk
1889                 )
1890                   `catchIO` (\_ -> return DocsFailed)
1891                   `catchExit` (\_ -> return DocsFailed)
1892               else return DocsNotTried
1893
1894           -- Tests phase
1895           onFailure TestsFailed $ do
1896             when (testsEnabled && PackageDescription.hasTests pkg) $
1897               setup Cabal.testCommand testFlags' mLogPath
1898
1899             let testsResult
1900                   | testsEnabled = TestsOk
1901                   | otherwise = TestsNotTried
1902
1903             -- Install phase
1904             onFailure InstallFailed $ criticalSection installLock $ do
1905               -- Actual installation
1906               withWin32SelfUpgrade
1907                 verbosity
1908                 uid
1909                 configFlags
1910                 cinfo
1911                 platform
1912                 pkg
1913                 $ do
1914                   setup Cabal.copyCommand copyFlags mLogPath
1915
1916               -- Capture installed package configuration file, so that
1917               -- it can be incorporated into the final InstallPlan
1918               ipkgs <- genPkgConfs mLogPath
1919               let ipkgs' = case ipkgs of
1920                     [ipkg] -> [ipkg{Installed.installedUnitId = uid}]
1921                     _ -> ipkgs
1922               let packageDBs =
1923                     interpretPackageDbFlags
1924                       (fromFlag (configUserInstall configFlags))
1925                       (configPackageDBs configFlags)
1926               for_ ipkgs' $ \ipkg' ->
1927                 registerPackage
1928                   verbosity
1929                   comp
1930                   progdb
1931                   packageDBs
1932                   ipkg'
1933                   defaultRegisterOptions
1934
1935               return (Right (BuildResult docsResult testsResult (find ((== uid) . installedUnitId) ipkgs')))
1936     where
1937       pkgid = packageId pkg
1938       uid = installedUnitId rpkg
1939       cinfo = compilerInfo comp
1940       buildCommand' = buildCommand progdb
1941       dispname = prettyShow pkgid
1942       isParallelBuild = numJobs >= 2
1943
1944       noticeProgress phase =
1945         when isParallelBuild $
1946           progressMessage verbosity phase dispname
1947
1948       buildFlags _ =
1949         emptyBuildFlags
1950           { buildDistPref = configDistPref configFlags
1951           , buildVerbosity = toFlag verbosity'
1952           }
1953       shouldHaddock = fromFlag (installDocumentation installFlags)
1954       haddockFlags' _ =
1955         haddockFlags
1956           { haddockVerbosity = toFlag verbosity'
1957           , haddockDistPref = configDistPref configFlags
1958           }
1959       testsEnabled =
1960         fromFlag (configTests configFlags)
1961           && fromFlagOrDefault False (installRunTests installFlags)
1962       testFlags' =
1963         filterTestFlags
1964           testFlags
1965             { Cabal.testDistPref = configDistPref configFlags
1966             }
1967       copyFlags _ =
1968         Cabal.emptyCopyFlags
1969           { Cabal.copyDistPref = configDistPref configFlags
1970           , Cabal.copyDest = toFlag InstallDirs.NoCopyDest
1971           , Cabal.copyVerbosity = toFlag verbosity'
1972           }
1973       shouldRegister = PackageDescription.hasLibs pkg
1974       registerFlags _ =
1975         Cabal.emptyRegisterFlags
1976           { Cabal.regDistPref = configDistPref configFlags
1977           , Cabal.regVerbosity = toFlag verbosity'
1978           }
1979       verbosity' = maybe verbosity snd useLogFile
1980       tempTemplate name = name ++ "-" ++ prettyShow pkgid
1981
1982       addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags
1983       addDefaultInstallDirs configFlags' = do
1984         defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False
1985         return $
1986           configFlags'
1987             { configInstallDirs =
1988                 fmap Cabal.Flag
1989                   . InstallDirs.substituteInstallDirTemplates env
1990                   $ InstallDirs.combineInstallDirs
1991                     fromFlagOrDefault
1992                     defInstallDirs
1993                     (configInstallDirs configFlags)
1994             }
1995         where
1996           CompilerId flavor _ = compilerInfoId cinfo
1997           env = initialPathTemplateEnv pkgid uid cinfo platform
1998           userInstall =
1999             fromFlagOrDefault
2000               defaultUserInstall
2001               (configUserInstall configFlags')
2002
2003       genPkgConfs
2004         :: Maybe FilePath
2005         -> IO [Installed.InstalledPackageInfo]
2006       genPkgConfs mLogPath =
2007         if shouldRegister
2008           then do
2009             tmp <- getTemporaryDirectory
2010             withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do
2011               let pkgConfDest = dir </> "pkgConf"
2012                   registerFlags' version =
2013                     (registerFlags version)
2014                       { Cabal.regGenPkgConf = toFlag (Just pkgConfDest)
2015                       }
2016               setup Cabal.registerCommand registerFlags' mLogPath
2017               is_dir <- doesDirectoryExist pkgConfDest
2018               let notHidden = not . isHidden
2019                   isHidden name = "." `isPrefixOf` name
2020               if is_dir
2021                 then -- Sort so that each prefix of the package
2022                 -- configurations is well formed
2023
2024                   traverse (readPkgConf pkgConfDest) . sort . filter notHidden
2025                     =<< getDirectoryContents pkgConfDest
2026                 else fmap (: []) $ readPkgConf "." pkgConfDest
2027           else return []
2028
2029       readPkgConf
2030         :: FilePath
2031         -> FilePath
2032         -> IO Installed.InstalledPackageInfo
2033       readPkgConf pkgConfDir pkgConfFile = do
2034         pkgConfText <- BS.readFile (pkgConfDir </> pkgConfFile)
2035         case Installed.parseInstalledPackageInfo pkgConfText of
2036           Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors
2037           Right (warns, pkgConf) -> do
2038             unless (null warns) $
2039               warn verbosity $
2040                 unlines warns
2041             return pkgConf
2042
2043       pkgConfParseFailed :: String -> IO a
2044       pkgConfParseFailed perror =
2045         dieWithException verbosity $ PkgConfParsedFailed perror
2046
2047       maybeLogPath :: IO (Maybe FilePath)
2048       maybeLogPath =
2049         case useLogFile of
2050           Nothing -> return Nothing
2051           Just (mkLogFileName, _) -> do
2052             let logFileName = mkLogFileName (packageId pkg) uid
2053                 logDir = takeDirectory logFileName
2054             unless (null logDir) $ createDirectoryIfMissing True logDir
2055             logFileExists <- doesFileExist logFileName
2056             when logFileExists $ removeFile logFileName
2057             return (Just logFileName)
2058
2059       setup cmd flags mLogPath =
2060         Exception.bracket
2061           (traverse (\path -> openFile path AppendMode) mLogPath)
2062           (traverse_ hClose)
2063           ( \logFileHandle ->
2064               setupWrapper
2065                 verbosity
2066                 scriptOptions
2067                   { useLoggingHandle = logFileHandle
2068                   , useWorkingDir = workingDir
2069                   }
2070                 (Just pkg)
2071                 cmd
2072                 flags
2073                 (const [])
2074           )
2075
2076 -- helper
2077 onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome
2078 onFailure result action =
2079   action
2080     `catches` [ Handler $ \ioe -> handler (ioe :: IOException)
2081               , Handler $ \cabalexe -> handler (cabalexe :: VerboseException CabalException)
2082               , Handler $ \exit -> handler (exit :: ExitCode)
2083               ]
2084   where
2085     handler :: Exception e => e -> IO BuildOutcome
2086     handler = return . Left . result . toException
2087
2088 -- ------------------------------------------------------------
2089
2090 -- * Weird windows hacks
2091
2092 -- ------------------------------------------------------------
2093
2094 withWin32SelfUpgrade
2095   :: Verbosity
2096   -> UnitId
2097   -> ConfigFlags
2098   -> CompilerInfo
2099   -> Platform
2100   -> PackageDescription
2101   -> IO a
2102   -> IO a
2103 withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action
2104 withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do
2105   defaultDirs <-
2106     InstallDirs.defaultInstallDirs
2107       compFlavor
2108       (fromFlag (configUserInstall configFlags))
2109       (PackageDescription.hasLibs pkg)
2110
2111   Win32SelfUpgrade.possibleSelfUpgrade
2112     verbosity
2113     (exeInstallPaths defaultDirs)
2114     action
2115   where
2116     pkgid = packageId pkg
2117     (CompilerId compFlavor _) = compilerInfoId cinfo
2118
2119     exeInstallPaths defaultDirs =
2120       [ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension buildPlatform
2121       | exe <- PackageDescription.executables pkg
2122       , PackageDescription.buildable (PackageDescription.buildInfo exe)
2123       , let exeName = prefix ++ prettyShow (PackageDescription.exeName exe) ++ suffix
2124             prefix = substTemplate prefixTemplate
2125             suffix = substTemplate suffixTemplate
2126       ]
2127       where
2128         fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
2129         prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)
2130         suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)
2131         templateDirs =
2132           InstallDirs.combineInstallDirs
2133             fromFlagOrDefault
2134             defaultDirs
2135             (configInstallDirs configFlags)
2136         absoluteDirs =
2137           InstallDirs.absoluteInstallDirs
2138             pkgid
2139             uid
2140             cinfo
2141             InstallDirs.NoCopyDest
2142             platform
2143             templateDirs
2144         substTemplate =
2145           InstallDirs.fromPathTemplate
2146             . InstallDirs.substPathTemplate env
2147           where
2148             env =
2149               InstallDirs.initialPathTemplateEnv
2150                 pkgid
2151                 uid
2152                 cinfo
2153                 platform