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

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