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

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE ViewPatterns #-}
   7
   8 -- | This module deals with building and incrementally rebuilding a collection
   9 -- of packages. It is what backs the @cabal build@ and @configure@ commands,
  10 -- as well as being a core part of @run@, @test@, @bench@ and others.
  11 --
  12 -- The primary thing is in fact rebuilding (and trying to make that quick by
  13 -- not redoing unnecessary work), so building from scratch is just a special
  14 -- case.
  15 --
  16 -- The build process and the code can be understood by breaking it down into
  17 -- three major parts:
  18 --
  19 -- * The 'ElaboratedInstallPlan' type
  20 --
  21 -- * The \"what to do\" phase, where we look at the all input configuration
  22 --   (project files, .cabal files, command line etc) and produce a detailed
  23 --   plan of what to do -- the 'ElaboratedInstallPlan'.
  24 --
  25 -- * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we
  26 -- re-execute it.
  27 --
  28 -- As far as possible, the \"what to do\" phase embodies all the policy, leaving
  29 -- the \"do it\" phase policy free. The first phase contains more of the
  30 -- complicated logic, but it is contained in code that is either pure or just
  31 -- has read effects (except cache updates). Then the second phase does all the
  32 -- actions to build packages, but as far as possible it just follows the
  33 -- instructions and avoids any logic for deciding what to do (apart from
  34 -- recompilation avoidance in executing the plan).
  35 --
  36 -- This division helps us keep the code under control, making it easier to
  37 -- understand, test and debug. So when you are extending these modules, please
  38 -- think about which parts of your change belong in which part. It is
  39 -- perfectly ok to extend the description of what to do (i.e. the
  40 -- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the
  41 -- first phase. Also, the second phase does not have direct access to any of
  42 -- the input configuration anyway; all the information has to flow via the
  43 -- 'ElaboratedInstallPlan'.
  44 module Distribution.Client.ProjectOrchestration
  45   ( -- * Discovery phase: what is in the project?
  46     CurrentCommand (..)
  47   , establishProjectBaseContext
  48   , establishProjectBaseContextWithRoot
  49   , ProjectBaseContext (..)
  50   , BuildTimeSettings (..)
  51   , commandLineFlagsToProjectConfig
  52
  53     -- * Pre-build phase: decide what to do.
  54   , withInstallPlan
  55   , runProjectPreBuildPhase
  56   , ProjectBuildContext (..)
  57
  58     -- ** Selecting what targets we mean
  59   , readTargetSelectors
  60   , reportTargetSelectorProblems
  61   , resolveTargets
  62   , TargetsMap
  63   , allTargetSelectors
  64   , uniqueTargetSelectors
  65   , TargetSelector (..)
  66   , TargetImplicitCwd (..)
  67   , PackageId
  68   , AvailableTarget (..)
  69   , AvailableTargetStatus (..)
  70   , TargetRequested (..)
  71   , ComponentName (..)
  72   , ComponentKind (..)
  73   , ComponentTarget (..)
  74   , SubComponentTarget (..)
  75   , selectComponentTargetBasic
  76   , distinctTargetComponents
  77
  78     -- ** Utils for selecting targets
  79   , filterTargetsKind
  80   , filterTargetsKindWith
  81   , selectBuildableTargets
  82   , selectBuildableTargetsWith
  83   , selectBuildableTargets'
  84   , selectBuildableTargetsWith'
  85   , forgetTargetsDetail
  86
  87     -- ** Adjusting the plan
  88   , pruneInstallPlanToTargets
  89   , TargetAction (..)
  90   , pruneInstallPlanToDependencies
  91   , CannotPruneDependencies (..)
  92   , printPlan
  93
  94     -- * Build phase: now do it.
  95   , runProjectBuildPhase
  96
  97     -- * Post build actions
  98   , runProjectPostBuildPhase
  99   , dieOnBuildFailures
 100
 101     -- * Dummy projects
 102   , establishDummyProjectBaseContext
 103   , establishDummyDistDirLayout
 104   ) where
 105
 106 import Distribution.Client.Compat.Prelude
 107 import Distribution.Compat.Directory
 108   ( makeAbsolute
 109   )
 110 import Prelude ()
 111
 112 import Distribution.Client.ProjectBuilding
 113 import Distribution.Client.ProjectConfig
 114 import Distribution.Client.ProjectPlanOutput
 115 import Distribution.Client.ProjectPlanning hiding
 116   ( pruneInstallPlanToTargets
 117   )
 118 import qualified Distribution.Client.ProjectPlanning as ProjectPlanning
 119   ( pruneInstallPlanToTargets
 120   )
 121 import Distribution.Client.ProjectPlanning.Types
 122
 123 import Distribution.Client.DistDirLayout
 124 import qualified Distribution.Client.InstallPlan as InstallPlan
 125 import Distribution.Client.TargetProblem
 126   ( TargetProblem (..)
 127   )
 128 import Distribution.Client.TargetSelector
 129   ( ComponentKind (..)
 130   , TargetImplicitCwd (..)
 131   , TargetSelector (..)
 132   , componentKind
 133   , readTargetSelectors
 134   , reportTargetSelectorProblems
 135   )
 136 import Distribution.Client.Types
 137   ( DocsResult (..)
 138   , GenericReadyPackage (..)
 139   , PackageLocation (..)
 140   , PackageSpecifier (..)
 141   , SourcePackageDb (..)
 142   , TestsResult (..)
 143   , UnresolvedSourcePackage
 144   , WriteGhcEnvironmentFilesPolicy (..)
 145   )
 146 import Distribution.Solver.Types.PackageIndex
 147   ( lookupPackageName
 148   )
 149
 150 import Distribution.Client.BuildReports.Anonymous (cabalInstallID)
 151 import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
 152 import qualified Distribution.Client.BuildReports.Storage as BuildReports
 153   ( storeLocal
 154   )
 155
 156 import Distribution.Client.HttpUtils
 157 import Distribution.Client.Setup hiding (packageName)
 158 import Distribution.Compiler
 159   ( CompilerFlavor (GHC)
 160   )
 161 import Distribution.Types.ComponentName
 162   ( componentNameString
 163   )
 164 import Distribution.Types.InstalledPackageInfo
 165   ( InstalledPackageInfo
 166   )
 167 import Distribution.Types.UnqualComponentName
 168   ( UnqualComponentName
 169   , packageNameToUnqualComponentName
 170   )
 171
 172 import Distribution.Solver.Types.OptionalStanza
 173
 174 import Control.Exception (assert)
 175 import qualified Data.List.NonEmpty as NE
 176 import qualified Data.Map as Map
 177 import qualified Data.Set as Set
 178 import Distribution.Client.Errors
 179 import Distribution.Package
 180 import Distribution.Simple.Command (commandShowOptions)
 181 import Distribution.Simple.Compiler
 182   ( OptimisationLevel (..)
 183   , compilerCompatVersion
 184   , compilerId
 185   , compilerInfo
 186   , showCompilerId
 187   )
 188 import Distribution.Simple.Configure (computeEffectiveProfiling)
 189 import Distribution.Simple.Flag
 190   ( flagToMaybe
 191   , fromFlagOrDefault
 192   )
 193 import Distribution.Simple.LocalBuildInfo
 194   ( ComponentName (..)
 195   , pkgComponents
 196   )
 197 import Distribution.Simple.PackageIndex (InstalledPackageIndex)
 198 import qualified Distribution.Simple.Setup as Setup
 199 import Distribution.Simple.Utils
 200   ( createDirectoryIfMissingVerbose
 201   , debugNoWrap
 202   , dieWithException
 203   , notice
 204   , noticeNoWrap
 205   , ordNub
 206   , warn
 207   )
 208 import Distribution.System
 209   ( Platform (Platform)
 210   )
 211 import Distribution.Types.Flag
 212   ( FlagAssignment
 213   , diffFlagAssignment
 214   , showFlagAssignment
 215   )
 216 import Distribution.Utils.NubList
 217   ( fromNubList
 218   )
 219 import Distribution.Utils.Path (makeSymbolicPath)
 220 import Distribution.Verbosity
 221 import Distribution.Version
 222   ( mkVersion
 223   )
 224 #ifdef MIN_VERSION_unix
 225 import           System.Posix.Signals (sigKILL, sigSEGV)
 226
 227 #endif
 228
 229 -- | Tracks what command is being executed, because we need to hide this somewhere
 230 -- for cases that need special handling (usually for error reporting).
 231 data CurrentCommand = InstallCommand | HaddockCommand | BuildCommand | ReplCommand | OtherCommand
 232   deriving (Show, Eq)
 233
 234 -- | This holds the context of a project prior to solving: the content of the
 235 -- @cabal.project@, @cabal/config@ and all the local package @.cabal@ files.
 236 data ProjectBaseContext = ProjectBaseContext
 237   { distDirLayout :: DistDirLayout
 238   , cabalDirLayout :: CabalDirLayout
 239   , projectConfig :: ProjectConfig
 240   , localPackages :: [PackageSpecifier UnresolvedSourcePackage]
 241   -- ^ Note: these are all the packages mentioned in the project configuration.
 242   -- Whether or not they will be considered local to the project will be decided
 243   -- by `shouldBeLocal` in ProjectPlanning.
 244   , buildSettings :: BuildTimeSettings
 245   , currentCommand :: CurrentCommand
 246   , installedPackages :: Maybe InstalledPackageIndex
 247   }
 248
 249 establishProjectBaseContext
 250   :: Verbosity
 251   -> ProjectConfig
 252   -> CurrentCommand
 253   -> IO ProjectBaseContext
 254 establishProjectBaseContext verbosity cliConfig currentCommand = do
 255   projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile
 256   establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand
 257   where
 258     mprojectDir = Setup.flagToMaybe projectConfigProjectDir
 259     mprojectFile = Setup.flagToMaybe projectConfigProjectFile
 260     ProjectConfigShared{projectConfigProjectDir, projectConfigProjectFile} = projectConfigShared cliConfig
 261
 262 -- | Like 'establishProjectBaseContext' but doesn't search for project root.
 263 establishProjectBaseContextWithRoot
 264   :: Verbosity
 265   -> ProjectConfig
 266   -> ProjectRoot
 267   -> CurrentCommand
 268   -> IO ProjectBaseContext
 269 establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do
 270   let haddockOutputDir = flagToMaybe (packageConfigHaddockOutputDir (projectConfigLocalPackages cliConfig))
 271   let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir
 272
 273   httpTransport <-
 274     configureTransport
 275       verbosity
 276       (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
 277       (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
 278
 279   (projectConfig, localPackages) <-
 280     rebuildProjectConfig
 281       verbosity
 282       httpTransport
 283       distDirLayout
 284       cliConfig
 285
 286   let ProjectConfigBuildOnly
 287         { projectConfigLogsDir
 288         } = projectConfigBuildOnly projectConfig
 289
 290       ProjectConfigShared
 291         { projectConfigStoreDir
 292         } = projectConfigShared projectConfig
 293
 294       mlogsDir = Setup.flagToMaybe projectConfigLogsDir
 295   mstoreDir <-
 296     sequenceA $
 297       makeAbsolute
 298         <$> Setup.flagToMaybe projectConfigStoreDir
 299
 300   cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
 301
 302   let buildSettings =
 303         resolveBuildTimeSettings
 304           verbosity
 305           cabalDirLayout
 306           projectConfig
 307
 308   -- https://github.com/haskell/cabal/issues/6013
 309   when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $
 310     warn verbosity "There are no packages or optional-packages in the project"
 311
 312   return
 313     ProjectBaseContext
 314       { distDirLayout
 315       , cabalDirLayout
 316       , projectConfig
 317       , localPackages
 318       , buildSettings
 319       , currentCommand
 320       , installedPackages
 321       }
 322   where
 323     mdistDirectory = Setup.flagToMaybe projectConfigDistDir
 324     ProjectConfigShared{projectConfigDistDir} = projectConfigShared cliConfig
 325     installedPackages = Nothing
 326
 327 -- | This holds the context between the pre-build, build and post-build phases.
 328 data ProjectBuildContext = ProjectBuildContext
 329   { elaboratedPlanOriginal :: ElaboratedInstallPlan
 330   -- ^ This is the improved plan, before we select a plan subset based on
 331   -- the build targets, and before we do the dry-run. So this contains
 332   -- all packages in the project.
 333   , elaboratedPlanToExecute :: ElaboratedInstallPlan
 334   -- ^ This is the 'elaboratedPlanOriginal' after we select a plan subset
 335   -- and do the dry-run phase to find out what is up-to or out-of date.
 336   -- This is the plan that will be executed during the build phase. So
 337   -- this contains only a subset of packages in the project.
 338   , elaboratedShared :: ElaboratedSharedConfig
 339   -- ^ The part of the install plan that's shared between all packages in
 340   -- the plan. This does not change between the two plan variants above,
 341   -- so there is just the one copy.
 342   , pkgsBuildStatus :: BuildStatusMap
 343   -- ^ The result of the dry-run phase. This tells us about each member of
 344   -- the 'elaboratedPlanToExecute'.
 345   , targetsMap :: TargetsMap
 346   -- ^ The targets selected by @selectPlanSubset@. This is useful eg. in
 347   -- CmdRun, where we need a valid target to execute.
 348   }
 349
 350 -- | Pre-build phase: decide what to do.
 351 withInstallPlan
 352   :: Verbosity
 353   -> ProjectBaseContext
 354   -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
 355   -> IO a
 356 withInstallPlan
 357   verbosity
 358   ProjectBaseContext
 359     { distDirLayout
 360     , cabalDirLayout
 361     , projectConfig
 362     , localPackages
 363     , installedPackages
 364     }
 365   action = do
 366     -- Take the project configuration and make a plan for how to build
 367     -- everything in the project. This is independent of any specific targets
 368     -- the user has asked for.
 369     --
 370     (elaboratedPlan, _, elaboratedShared, _, _) <-
 371       rebuildInstallPlan
 372         verbosity
 373         distDirLayout
 374         cabalDirLayout
 375         projectConfig
 376         localPackages
 377         installedPackages
 378     action elaboratedPlan elaboratedShared
 379
 380 runProjectPreBuildPhase
 381   :: Verbosity
 382   -> ProjectBaseContext
 383   -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
 384   -> IO ProjectBuildContext
 385 runProjectPreBuildPhase
 386   verbosity
 387   ProjectBaseContext
 388     { distDirLayout
 389     , cabalDirLayout
 390     , projectConfig
 391     , localPackages
 392     , installedPackages
 393     }
 394   selectPlanSubset = do
 395     -- Take the project configuration and make a plan for how to build
 396     -- everything in the project. This is independent of any specific targets
 397     -- the user has asked for.
 398     --
 399     (elaboratedPlan, _, elaboratedShared, _, _) <-
 400       rebuildInstallPlan
 401         verbosity
 402         distDirLayout
 403         cabalDirLayout
 404         projectConfig
 405         localPackages
 406         installedPackages
 407
 408     -- The plan for what to do is represented by an 'ElaboratedInstallPlan'
 409
 410     -- Now given the specific targets the user has asked for, decide
 411     -- which bits of the plan we will want to execute.
 412     --
 413     (elaboratedPlan', targets) <- selectPlanSubset elaboratedPlan
 414
 415     -- Check which packages need rebuilding.
 416     -- This also gives us more accurate reasons for the --dry-run output.
 417     --
 418     pkgsBuildStatus <-
 419       rebuildTargetsDryRun
 420         distDirLayout
 421         elaboratedShared
 422         elaboratedPlan'
 423
 424     -- Improve the plan by marking up-to-date packages as installed.
 425     --
 426     let elaboratedPlan'' =
 427           improveInstallPlanWithUpToDatePackages
 428             pkgsBuildStatus
 429             elaboratedPlan'
 430     debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')
 431
 432     return
 433       ProjectBuildContext
 434         { elaboratedPlanOriginal = elaboratedPlan
 435         , elaboratedPlanToExecute = elaboratedPlan''
 436         , elaboratedShared
 437         , pkgsBuildStatus
 438         , targetsMap = targets
 439         }
 440
 441 -- | Build phase: now do it.
 442 --
 443 -- Execute all or parts of the description of what to do to build or
 444 -- rebuild the various packages needed.
 445 runProjectBuildPhase
 446   :: Verbosity
 447   -> ProjectBaseContext
 448   -> ProjectBuildContext
 449   -> IO BuildOutcomes
 450 runProjectBuildPhase _ ProjectBaseContext{buildSettings} _
 451   | buildSettingDryRun buildSettings =
 452       return Map.empty
 453 runProjectBuildPhase
 454   verbosity
 455   ProjectBaseContext{..}
 456   ProjectBuildContext{..} =
 457     fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $
 458       rebuildTargets
 459         verbosity
 460         projectConfig
 461         distDirLayout
 462         (cabalStoreDirLayout cabalDirLayout)
 463         elaboratedPlanToExecute
 464         elaboratedShared
 465         pkgsBuildStatus
 466         buildSettings
 467     where
 468       previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes
 469       previousBuildOutcomes =
 470         Map.mapMaybe $ \status -> case status of
 471           BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess)
 472           -- TODO: [nice to have] record build failures persistently
 473           _ -> Nothing
 474
 475 -- | Post-build phase: various administrative tasks
 476 --
 477 -- Update bits of state based on the build outcomes and report any failures.
 478 runProjectPostBuildPhase
 479   :: Verbosity
 480   -> ProjectBaseContext
 481   -> ProjectBuildContext
 482   -> BuildOutcomes
 483   -> IO ()
 484 runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _
 485   | buildSettingDryRun buildSettings =
 486       return ()
 487 runProjectPostBuildPhase
 488   verbosity
 489   ProjectBaseContext{..}
 490   bc@ProjectBuildContext{..}
 491   buildOutcomes = do
 492     -- Update other build artefacts
 493     -- TODO: currently none, but could include:
 494     --        - bin symlinks/wrappers
 495     --        - haddock/hoogle/ctags indexes
 496     --        - delete stale lib registrations
 497     --        - delete stale package dirs
 498
 499     postBuildStatus <-
 500       updatePostBuildProjectStatus
 501         verbosity
 502         distDirLayout
 503         elaboratedPlanOriginal
 504         pkgsBuildStatus
 505         buildOutcomes
 506
 507     -- Write the .ghc.environment file (if allowed by the env file write policy).
 508     let writeGhcEnvFilesPolicy =
 509           projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared $
 510             projectConfig
 511
 512         shouldWriteGhcEnvironment :: Bool
 513         shouldWriteGhcEnvironment =
 514           case fromFlagOrDefault
 515             NeverWriteGhcEnvironmentFiles
 516             writeGhcEnvFilesPolicy of
 517             AlwaysWriteGhcEnvironmentFiles -> True
 518             NeverWriteGhcEnvironmentFiles -> False
 519             WriteGhcEnvironmentFilesOnlyForGhc844AndNewer ->
 520               let compiler = pkgConfigCompiler elaboratedShared
 521                   ghcCompatVersion = compilerCompatVersion GHC compiler
 522                in maybe False (>= mkVersion [8, 4, 4]) ghcCompatVersion
 523
 524     when shouldWriteGhcEnvironment $
 525       void $
 526         writePlanGhcEnvironment
 527           (distProjectRootDirectory distDirLayout)
 528           elaboratedPlanOriginal
 529           elaboratedShared
 530           postBuildStatus
 531
 532     -- Write the build reports
 533     writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes
 534
 535     -- Finally if there were any build failures then report them and throw
 536     -- an exception to terminate the program
 537     dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes
 538
 539 -- Note that it is a deliberate design choice that the 'buildTargets' is
 540 -- not passed to phase 1, and the various bits of input config is not
 541 -- passed to phase 2.
 542 --
 543 -- We make the install plan without looking at the particular targets the
 544 -- user asks us to build. The set of available things we can build is
 545 -- discovered from the env and config and is used to make the install plan.
 546 -- The targets just tell us which parts of the install plan to execute.
 547 --
 548 -- Conversely, executing the plan does not directly depend on any of the
 549 -- input config. The bits that are needed (or better, the decisions based
 550 -- on it) all go into the install plan.
 551
 552 -- Notionally, the 'BuildFlags' should be things that do not affect what
 553 -- we build, just how we do it. These ones of course do
 554
 555 ------------------------------------------------------------------------------
 556 -- Taking targets into account, selecting what to build
 557 --
 558
 559 -- | The set of components to build, represented as a mapping from 'UnitId's
 560 -- to the 'ComponentTarget's within the unit that will be selected
 561 -- (e.g. selected to build, test or repl).
 562 --
 563 -- Associated with each 'ComponentTarget' is the set of 'TargetSelector's that
 564 -- matched this target. Typically this is exactly one, but in general it is
 565 -- possible to for different selectors to match the same target. This extra
 566 -- information is primarily to help make helpful error messages.
 567 type TargetsMap = Map UnitId [(ComponentTarget, NonEmpty TargetSelector)]
 568
 569 -- | Get all target selectors.
 570 allTargetSelectors :: TargetsMap -> [TargetSelector]
 571 allTargetSelectors = concatMap (NE.toList . snd) . concat . Map.elems
 572
 573 -- | Get all unique target selectors.
 574 uniqueTargetSelectors :: TargetsMap -> [TargetSelector]
 575 uniqueTargetSelectors = ordNub . allTargetSelectors
 576
 577 -- | Given a set of 'TargetSelector's, resolve which 'UnitId's and
 578 -- 'ComponentTarget's they ought to refer to.
 579 --
 580 -- The idea is that every user target identifies one or more roots in the
 581 -- 'ElaboratedInstallPlan', which we will use to determine the closure
 582 -- of what packages need to be built, dropping everything from the plan
 583 -- that is unnecessary. This closure and pruning is done by
 584 -- 'pruneInstallPlanToTargets' and this needs to be told the roots in terms
 585 -- of 'UnitId's and the 'ComponentTarget's within those.
 586 --
 587 -- This means we first need to translate the 'TargetSelector's into the
 588 -- 'UnitId's and 'ComponentTarget's. This translation has to be different for
 589 -- the different command line commands, like @build@, @repl@ etc. For example
 590 -- the command @build pkgfoo@ could select a different set of components in
 591 -- pkgfoo than @repl pkgfoo@. The @build@ command would select any library and
 592 -- all executables, whereas @repl@ would select the library or a single
 593 -- executable. Furthermore, both of these examples could fail, and fail in
 594 -- different ways and each needs to be able to produce helpful error messages.
 595 --
 596 -- So 'resolveTargets' takes two helpers: one to select the targets to be used
 597 -- by user targets that refer to a whole package ('TargetPackage'), and
 598 -- another to check user targets that refer to a component (or a module or
 599 -- file within a component). These helpers can fail, and use their own error
 600 -- type. Both helpers get given the 'AvailableTarget' info about the
 601 -- component(s).
 602 --
 603 -- While commands vary quite a bit in their behaviour about which components to
 604 -- select for a whole-package target, most commands have the same behaviour for
 605 -- checking a user target that refers to a specific component. To help with
 606 -- this commands can use 'selectComponentTargetBasic', either directly or as
 607 -- a basis for their own @selectComponentTarget@ implementation.
 608 resolveTargets
 609   :: forall err
 610    . ( forall k
 611         . TargetSelector
 612        -> [AvailableTarget k]
 613        -> Either (TargetProblem err) [k]
 614      )
 615   -> ( forall k
 616         . SubComponentTarget
 617        -> AvailableTarget k
 618        -> Either (TargetProblem err) k
 619      )
 620   -> ElaboratedInstallPlan
 621   -> Maybe (SourcePackageDb)
 622   -> [TargetSelector]
 623   -> Either [TargetProblem err] TargetsMap
 624 resolveTargets
 625   selectPackageTargets
 626   selectComponentTarget
 627   installPlan
 628   mPkgDb =
 629     fmap mkTargetsMap
 630       . either (Left . toList) Right
 631       . checkErrors
 632       . map (\ts -> (,) ts <$> checkTarget ts)
 633     where
 634       mkTargetsMap
 635         :: [(TargetSelector, [(UnitId, ComponentTarget)])]
 636         -> TargetsMap
 637       mkTargetsMap targets =
 638         Map.map nubComponentTargets $
 639           Map.fromListWith
 640             (<>)
 641             [ (uid, [(ct, ts)])
 642             | (ts, cts) <- targets
 643             , (uid, ct) <- cts
 644             ]
 645
 646       AvailableTargetIndexes{..} = availableTargetIndexes installPlan
 647
 648       checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)]
 649
 650       -- We can ask to build any whole package, project-local or a dependency
 651       checkTarget bt@(TargetPackage _ (ordNub -> [pkgid]) mkfilter)
 652         | Just ats <-
 653             fmap (maybe id filterTargetsKind mkfilter) $
 654               Map.lookup pkgid availableTargetsByPackageId =
 655             fmap (componentTargets WholeComponent) $
 656               selectPackageTargets bt ats
 657         | otherwise =
 658             Left (TargetProblemNoSuchPackage pkgid)
 659       checkTarget (TargetPackage _ pkgids _) =
 660         error
 661           ( "TODO: add support for multiple packages in a directory.  Got\n"
 662               ++ unlines (map prettyShow pkgids)
 663           )
 664       -- For the moment this error cannot happen here, because it gets
 665       -- detected when the package config is being constructed. This case
 666       -- will need handling properly when we do add support.
 667       --
 668       -- TODO: how should this use case play together with the
 669       -- '--cabal-file' option of 'configure' which allows using multiple
 670       -- .cabal files for a single package?
 671
 672       checkTarget bt@(TargetAllPackages mkfilter) =
 673         fmap (componentTargets WholeComponent)
 674           . selectPackageTargets bt
 675           . maybe id filterTargetsKind mkfilter
 676           . filter availableTargetLocalToProject
 677           $ concat (Map.elems availableTargetsByPackageId)
 678       checkTarget (TargetComponent pkgid cname subtarget)
 679         | Just ats <-
 680             Map.lookup
 681               (pkgid, cname)
 682               availableTargetsByPackageIdAndComponentName =
 683             fmap (componentTargets subtarget) $
 684               selectComponentTargets subtarget ats
 685         | Map.member pkgid availableTargetsByPackageId =
 686             Left (TargetProblemNoSuchComponent pkgid cname)
 687         | otherwise =
 688             Left (TargetProblemNoSuchPackage pkgid)
 689       checkTarget (TargetComponentUnknown pkgname ecname subtarget)
 690         | Just ats <- case ecname of
 691             Left ucname ->
 692               Map.lookup
 693                 (pkgname, ucname)
 694                 availableTargetsByPackageNameAndUnqualComponentName
 695             Right cname ->
 696               Map.lookup
 697                 (pkgname, cname)
 698                 availableTargetsByPackageNameAndComponentName =
 699             fmap (componentTargets subtarget) $
 700               selectComponentTargets subtarget ats
 701         | Map.member pkgname availableTargetsByPackageName =
 702             Left (TargetProblemUnknownComponent pkgname ecname)
 703         | otherwise =
 704             Left (TargetNotInProject pkgname)
 705       checkTarget bt@(TargetPackageNamed pkgname mkfilter)
 706         | Just ats <-
 707             fmap (maybe id filterTargetsKind mkfilter) $
 708               Map.lookup pkgname availableTargetsByPackageName =
 709             fmap (componentTargets WholeComponent)
 710               . selectPackageTargets bt
 711               $ ats
 712         | Just SourcePackageDb{packageIndex} <- mPkgDb
 713         , let pkg = lookupPackageName packageIndex pkgname
 714         , not (null pkg) =
 715             Left (TargetAvailableInIndex pkgname)
 716         | otherwise =
 717             Left (TargetNotInProject pkgname)
 718
 719       componentTargets
 720         :: SubComponentTarget
 721         -> [(b, ComponentName)]
 722         -> [(b, ComponentTarget)]
 723       componentTargets subtarget =
 724         map (fmap (\cname -> ComponentTarget cname subtarget))
 725
 726       selectComponentTargets
 727         :: SubComponentTarget
 728         -> [AvailableTarget k]
 729         -> Either (TargetProblem err) [k]
 730       selectComponentTargets subtarget =
 731         either (Left . NE.head) Right
 732           . checkErrors
 733           . map (selectComponentTarget subtarget)
 734
 735       checkErrors :: [Either e a] -> Either (NonEmpty e) [a]
 736       checkErrors =
 737         (\(es, xs) -> case es of [] -> Right xs; (e : es') -> Left (e :| es'))
 738           . partitionEithers
 739
 740 data AvailableTargetIndexes = AvailableTargetIndexes
 741   { availableTargetsByPackageIdAndComponentName
 742       :: AvailableTargetsMap (PackageId, ComponentName)
 743   , availableTargetsByPackageId
 744       :: AvailableTargetsMap PackageId
 745   , availableTargetsByPackageName
 746       :: AvailableTargetsMap PackageName
 747   , availableTargetsByPackageNameAndComponentName
 748       :: AvailableTargetsMap (PackageName, ComponentName)
 749   , availableTargetsByPackageNameAndUnqualComponentName
 750       :: AvailableTargetsMap (PackageName, UnqualComponentName)
 751   }
 752 type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)]
 753
 754 -- We define a bunch of indexes to help 'resolveTargets' with resolving
 755 -- 'TargetSelector's to specific 'UnitId's.
 756 --
 757 -- They are all derived from the 'availableTargets' index.
 758 -- The 'availableTargetsByPackageIdAndComponentName' is just that main index,
 759 -- while the others are derived by re-grouping on the index key.
 760 --
 761 -- They are all constructed lazily because they are not necessarily all used.
 762 --
 763 availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes
 764 availableTargetIndexes installPlan = AvailableTargetIndexes{..}
 765   where
 766     availableTargetsByPackageIdAndComponentName
 767       :: Map
 768           (PackageId, ComponentName)
 769           [AvailableTarget (UnitId, ComponentName)]
 770     availableTargetsByPackageIdAndComponentName =
 771       availableTargets installPlan
 772
 773     availableTargetsByPackageId
 774       :: Map PackageId [AvailableTarget (UnitId, ComponentName)]
 775     availableTargetsByPackageId =
 776       Map.mapKeysWith
 777         (++)
 778         (\(pkgid, _cname) -> pkgid)
 779         availableTargetsByPackageIdAndComponentName
 780         `Map.union` availableTargetsEmptyPackages
 781
 782     availableTargetsByPackageName
 783       :: Map PackageName [AvailableTarget (UnitId, ComponentName)]
 784     availableTargetsByPackageName =
 785       Map.mapKeysWith
 786         (++)
 787         packageName
 788         availableTargetsByPackageId
 789
 790     availableTargetsByPackageNameAndComponentName
 791       :: Map
 792           (PackageName, ComponentName)
 793           [AvailableTarget (UnitId, ComponentName)]
 794     availableTargetsByPackageNameAndComponentName =
 795       Map.mapKeysWith
 796         (++)
 797         (\(pkgid, cname) -> (packageName pkgid, cname))
 798         availableTargetsByPackageIdAndComponentName
 799
 800     availableTargetsByPackageNameAndUnqualComponentName
 801       :: Map
 802           (PackageName, UnqualComponentName)
 803           [AvailableTarget (UnitId, ComponentName)]
 804     availableTargetsByPackageNameAndUnqualComponentName =
 805       Map.mapKeysWith
 806         (++)
 807         ( \(pkgid, cname) ->
 808             let pname = packageName pkgid
 809                 cname' = unqualComponentName pname cname
 810              in (pname, cname')
 811         )
 812         availableTargetsByPackageIdAndComponentName
 813       where
 814         unqualComponentName
 815           :: PackageName -> ComponentName -> UnqualComponentName
 816         unqualComponentName pkgname =
 817           fromMaybe (packageNameToUnqualComponentName pkgname)
 818             . componentNameString
 819
 820     -- Add in all the empty packages. These do not appear in the
 821     -- availableTargetsByComponent map, since that only contains
 822     -- components, so packages with no components are invisible from
 823     -- that perspective.  The empty packages need to be there for
 824     -- proper error reporting, so users can select the empty package
 825     -- and then we can report that it is empty, otherwise we falsely
 826     -- report there is no such package at all.
 827     availableTargetsEmptyPackages =
 828       Map.fromList
 829         [ (packageId pkg, [])
 830         | InstallPlan.Configured pkg <- InstallPlan.toList installPlan
 831         , case elabPkgOrComp pkg of
 832             ElabComponent _ -> False
 833             ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg))
 834         ]
 835
 836 -- TODO: [research required] what if the solution has multiple
 837 --      versions of this package?
 838 --      e.g. due to setup deps or due to multiple independent sets
 839 --      of packages being built (e.g. ghc + ghcjs in a project)
 840
 841 filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
 842 filterTargetsKind ckind = filterTargetsKindWith (== ckind)
 843
 844 filterTargetsKindWith
 845   :: (ComponentKind -> Bool)
 846   -> [AvailableTarget k]
 847   -> [AvailableTarget k]
 848 filterTargetsKindWith p ts =
 849   [ t | t@(AvailableTarget _ cname _ _) <- ts, p (componentKind cname)
 850   ]
 851
 852 selectBuildableTargets :: [AvailableTarget k] -> [k]
 853 selectBuildableTargets = selectBuildableTargetsWith (const True)
 854
 855 zipBuildableTargetsWith
 856   :: (TargetRequested -> Bool)
 857   -> [AvailableTarget k]
 858   -> [(k, AvailableTarget k)]
 859 zipBuildableTargetsWith p ts =
 860   [(k, t) | t@(AvailableTarget _ _ (TargetBuildable k req) _) <- ts, p req]
 861
 862 selectBuildableTargetsWith
 863   :: (TargetRequested -> Bool)
 864   -> [AvailableTarget k]
 865   -> [k]
 866 selectBuildableTargetsWith p = map fst . zipBuildableTargetsWith p
 867
 868 selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()])
 869 selectBuildableTargets' = selectBuildableTargetsWith' (const True)
 870
 871 selectBuildableTargetsWith'
 872   :: (TargetRequested -> Bool)
 873   -> [AvailableTarget k]
 874   -> ([k], [AvailableTarget ()])
 875 selectBuildableTargetsWith' p =
 876   (fmap . map) forgetTargetDetail . unzip . zipBuildableTargetsWith p
 877
 878 forgetTargetDetail :: AvailableTarget k -> AvailableTarget ()
 879 forgetTargetDetail = fmap (const ())
 880
 881 forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()]
 882 forgetTargetsDetail = map forgetTargetDetail
 883
 884 -- | A basic @selectComponentTarget@ implementation to use or pass to
 885 -- 'resolveTargets', that does the basic checks that the component is
 886 -- buildable and isn't a test suite or benchmark that is disabled. This
 887 -- can also be used to do these basic checks as part of a custom impl that
 888 selectComponentTargetBasic
 889   :: SubComponentTarget
 890   -> AvailableTarget k
 891   -> Either (TargetProblem a) k
 892 selectComponentTargetBasic
 893   subtarget
 894   AvailableTarget
 895     { availableTargetPackageId = pkgid
 896     , availableTargetComponentName = cname
 897     , availableTargetStatus
 898     } =
 899     case availableTargetStatus of
 900       TargetDisabledByUser ->
 901         Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget)
 902       TargetDisabledBySolver ->
 903         Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget)
 904       TargetNotLocal ->
 905         Left (TargetComponentNotProjectLocal pkgid cname subtarget)
 906       TargetNotBuildable ->
 907         Left (TargetComponentNotBuildable pkgid cname subtarget)
 908       TargetBuildable targetKey _ ->
 909         Right targetKey
 910
 911 -- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts
 912 -- for the extra unneeded info in the 'TargetsMap'.
 913 pruneInstallPlanToTargets
 914   :: TargetAction
 915   -> TargetsMap
 916   -> ElaboratedInstallPlan
 917   -> ElaboratedInstallPlan
 918 pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan =
 919   assert (Map.size targetsMap > 0) $
 920     ProjectPlanning.pruneInstallPlanToTargets
 921       targetActionType
 922       (Map.map (map fst) targetsMap)
 923       elaboratedPlan
 924
 925 -- | Utility used by repl and run to check if the targets spans multiple
 926 -- components, since those commands do not support multiple components.
 927 distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName)
 928 distinctTargetComponents targetsMap =
 929   Set.fromList
 930     [ (uid, cname)
 931     | (uid, cts) <- Map.toList targetsMap
 932     , (ComponentTarget cname _, _) <- cts
 933     ]
 934
 935 ------------------------------------------------------------------------------
 936 -- Displaying what we plan to do
 937 --
 938
 939 -- | Print a user-oriented presentation of the install plan, indicating what
 940 -- will be built.
 941 printPlan
 942   :: Verbosity
 943   -> ProjectBaseContext
 944   -> ProjectBuildContext
 945   -> IO ()
 946 printPlan
 947   verbosity
 948   ProjectBaseContext
 949     { buildSettings = BuildTimeSettings{buildSettingDryRun, buildSettingKeepTempFiles}
 950     , projectConfig =
 951       ProjectConfig
 952         { projectConfigAllPackages =
 953           PackageConfig{packageConfigOptimization = globalOptimization}
 954         , projectConfigLocalPackages =
 955           PackageConfig{packageConfigOptimization = localOptimization}
 956         }
 957     , currentCommand
 958     }
 959   ProjectBuildContext
 960     { elaboratedPlanToExecute = elaboratedPlan
 961     , elaboratedShared
 962     , pkgsBuildStatus
 963     }
 964     | null pkgs && currentCommand == BuildCommand =
 965         notice verbosity "Up to date"
 966     | not (null pkgs) =
 967         noticeNoWrap verbosity $
 968           unlines $
 969             ( showBuildProfile
 970                 ++ "In order, the following "
 971                 ++ wouldWill
 972                 ++ " be built"
 973                 ++ ifNormal " (use -v for more details)"
 974                 ++ ":"
 975             )
 976               : map showPkgAndReason pkgs
 977     | otherwise = return ()
 978     where
 979       pkgs = InstallPlan.executionOrder elaboratedPlan
 980
 981       ifVerbose s
 982         | verbosity >= verbose = s
 983         | otherwise = ""
 984
 985       ifNormal s
 986         | verbosity >= verbose = ""
 987         | otherwise = s
 988
 989       wouldWill
 990         | buildSettingDryRun = "would"
 991         | otherwise = "will"
 992
 993       showPkgAndReason :: ElaboratedReadyPackage -> String
 994       showPkgAndReason (ReadyPackage elab) =
 995         unwords $
 996           filter (not . null) $
 997             [ " -"
 998             , if verbosity >= deafening
 999                 then prettyShow (installedUnitId elab)
1000                 else prettyShow (packageId elab)
1001             , case elabBuildStyle elab of
1002                 BuildInplaceOnly InMemory -> "(interactive)"
1003                 _ -> ""
1004             , case elabPkgOrComp elab of
1005                 ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg))
1006                 ElabComponent comp ->
1007                   "(" ++ showComp elab comp ++ ")"
1008             , showFlagAssignment (nonDefaultFlags elab)
1009             , showConfigureFlags elab
1010             , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab
1011                in "(" ++ showBuildStatus buildStatus ++ ")"
1012             ]
1013
1014       showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String
1015       showComp elab comp =
1016         maybe "custom" prettyShow (compComponentName comp)
1017           ++ if Map.null (elabInstantiatedWith elab)
1018             then ""
1019             else
1020               " with "
1021                 ++ intercalate
1022                   ", "
1023                   -- TODO: Abbreviate the UnitIds
1024                   [ prettyShow k ++ "=" ++ prettyShow v
1025                   | (k, v) <- Map.toList (elabInstantiatedWith elab)
1026                   ]
1027
1028       nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment
1029       nonDefaultFlags elab =
1030         elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab
1031
1032       showTargets :: ElaboratedConfiguredPackage -> String
1033       showTargets elab
1034         | null (elabBuildTargets elab) = ""
1035         | otherwise =
1036             "("
1037               ++ intercalate
1038                 ", "
1039                 [ showComponentTarget (packageId elab) t
1040                 | t <- elabBuildTargets elab
1041                 ]
1042               ++ ")"
1043
1044       showConfigureFlags :: ElaboratedConfiguredPackage -> String
1045       showConfigureFlags elab =
1046         let commonFlags =
1047               setupHsCommonFlags
1048                 verbosity
1049                 Nothing -- omit working directory
1050                 (makeSymbolicPath "$builddir")
1051                 buildSettingKeepTempFiles
1052             fullConfigureFlags =
1053               runIdentity $
1054                 ( setupHsConfigureFlags
1055                     (\_ -> return (error "unused"))
1056                     elaboratedPlan
1057                     (ReadyPackage elab)
1058                     elaboratedShared
1059                     commonFlags
1060                 )
1061             -- \| Given a default value @x@ for a flag, nub @Flag x@
1062             -- into @NoFlag@.  This gives us a tidier command line
1063             -- rendering.
1064             nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a
1065             nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag
1066             nubFlag _ f = f
1067
1068             (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) =
1069               computeEffectiveProfiling fullConfigureFlags
1070
1071             partialConfigureFlags =
1072               mempty
1073                 { configProf =
1074                     nubFlag False (configProf fullConfigureFlags)
1075                 , configProfExe =
1076                     nubFlag tryExeProfiling (configProfExe fullConfigureFlags)
1077                 , configProfLib =
1078                     nubFlag tryLibProfiling (configProfLib fullConfigureFlags)
1079                 , configProfShared =
1080                     nubFlag tryLibProfilingShared (configProfShared fullConfigureFlags)
1081                 }
1082          in -- Not necessary to "escape" it, it's just for user output
1083             unwords . ("" :) $
1084               commandShowOptions
1085                 (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))
1086                 partialConfigureFlags
1087
1088       showBuildStatus :: BuildStatus -> String
1089       showBuildStatus status = case status of
1090         BuildStatusPreExisting -> "existing package"
1091         BuildStatusInstalled -> "already installed"
1092         BuildStatusDownload{} -> "requires download & build"
1093         BuildStatusUnpack{} -> "requires build"
1094         BuildStatusRebuild _ rebuild -> case rebuild of
1095           BuildStatusConfigure
1096             (MonitoredValueChanged _) -> "configuration changed"
1097           BuildStatusConfigure mreason -> showMonitorChangedReason mreason
1098           BuildStatusBuild _ buildreason -> case buildreason of
1099             BuildReasonDepsRebuilt -> "dependency rebuilt"
1100             BuildReasonFilesChanged
1101               mreason -> showMonitorChangedReason mreason
1102             BuildReasonExtraTargets _ -> "additional components to build"
1103             BuildReasonEphemeralTargets -> "ephemeral targets"
1104         BuildStatusUpToDate{} -> "up to date" -- doesn't happen
1105       showMonitorChangedReason :: MonitorChangedReason a -> String
1106       showMonitorChangedReason (MonitoredFileChanged file) =
1107         "file " ++ file ++ " changed"
1108       showMonitorChangedReason (MonitoredValueChanged _) = "value changed"
1109       showMonitorChangedReason MonitorFirstRun = "first run"
1110       showMonitorChangedReason MonitorCorruptCache =
1111         "cannot read state cache"
1112
1113       showBuildProfile :: String
1114       showBuildProfile =
1115         "Build profile: "
1116           ++ unwords
1117             [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared
1118             , "-O"
1119                 ++ ( case globalOptimization <> localOptimization of -- if local is not set, read global
1120                       Setup.Flag NoOptimisation -> "0"
1121                       Setup.Flag NormalOptimisation -> "1"
1122                       Setup.Flag MaximumOptimisation -> "2"
1123                       Setup.NoFlag -> "1"
1124                    )
1125             ]
1126           ++ "\n"
1127
1128 writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()
1129 writeBuildReports settings buildContext plan buildOutcomes = do
1130   let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext
1131       comp = pkgConfigCompiler . elaboratedShared $ buildContext
1132       getRepo (RepoTarballPackage r _ _) = Just r
1133       getRepo _ = Nothing
1134       fromPlanPackage (InstallPlan.Configured pkg) (Just result) =
1135         let installOutcome = case result of
1136               Left bf -> case buildFailureReason bf of
1137                 GracefulFailure _ -> BuildReports.PlanningFailed
1138                 DependentFailed p -> BuildReports.DependencyFailed p
1139                 DownloadFailed _ -> BuildReports.DownloadFailed
1140                 UnpackFailed _ -> BuildReports.UnpackFailed
1141                 ConfigureFailed _ -> BuildReports.ConfigureFailed
1142                 BuildFailed _ -> BuildReports.BuildFailed
1143                 TestsFailed _ -> BuildReports.TestsFailed
1144                 InstallFailed _ -> BuildReports.InstallFailed
1145                 ReplFailed _ -> BuildReports.InstallOk
1146                 HaddocksFailed _ -> BuildReports.InstallOk
1147                 BenchFailed _ -> BuildReports.InstallOk
1148               Right _br -> BuildReports.InstallOk
1149
1150             docsOutcome = case result of
1151               Left bf -> case buildFailureReason bf of
1152                 HaddocksFailed _ -> BuildReports.Failed
1153                 _ -> BuildReports.NotTried
1154               Right br -> case buildResultDocs br of
1155                 DocsNotTried -> BuildReports.NotTried
1156                 DocsFailed -> BuildReports.Failed
1157                 DocsOk -> BuildReports.Ok
1158
1159             testsOutcome = case result of
1160               Left bf -> case buildFailureReason bf of
1161                 TestsFailed _ -> BuildReports.Failed
1162                 _ -> BuildReports.NotTried
1163               Right br -> case buildResultTests br of
1164                 TestsNotTried -> BuildReports.NotTried
1165                 TestsOk -> BuildReports.Ok
1166          in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files?
1167       fromPlanPackage _ _ = Nothing
1168       buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan
1169
1170   BuildReports.storeLocal
1171     (compilerInfo comp)
1172     (buildSettingSummaryFile settings)
1173     buildReports
1174     plat
1175
1176 -- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1
1177 -- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle.
1178
1179 -- | If there are build failures then report them and throw an exception.
1180 dieOnBuildFailures
1181   :: Verbosity
1182   -> CurrentCommand
1183   -> ElaboratedInstallPlan
1184   -> BuildOutcomes
1185   -> IO ()
1186 dieOnBuildFailures verbosity currentCommand plan buildOutcomes
1187   | null failures = return ()
1188   | isSimpleCase = exitFailure
1189   | otherwise = do
1190       -- For failures where we have a build log, print the log plus a header
1191       sequence_
1192         [ do
1193           notice verbosity $
1194             '\n'
1195               : renderFailureDetail False pkg reason
1196               ++ "\nBuild log ( "
1197               ++ logfile
1198               ++ " ):"
1199           readFile logfile >>= noticeNoWrap verbosity
1200         | (pkg, ShowBuildSummaryAndLog reason logfile) <-
1201             failuresClassification
1202         ]
1203
1204       -- For all failures, print either a short summary (if we showed the
1205       -- build log) or all details
1206       dieIfNotHaddockFailure verbosity $
1207         unlines
1208           [ case failureClassification of
1209             ShowBuildSummaryAndLog reason _
1210               | verbosity > normal ->
1211                   renderFailureDetail mentionDepOf pkg reason
1212               | otherwise ->
1213                   renderFailureSummary mentionDepOf pkg reason
1214                     ++ ". See the build log above for details."
1215             ShowBuildSummaryOnly reason ->
1216               renderFailureDetail mentionDepOf pkg reason
1217           | let mentionDepOf = verbosity <= normal
1218           , (pkg, failureClassification) <- failuresClassification
1219           ]
1220   where
1221     failures :: [(UnitId, BuildFailure)]
1222     failures =
1223       [ (pkgid, failure)
1224       | (pkgid, Left failure) <- Map.toList buildOutcomes
1225       ]
1226
1227     failuresClassification :: [(ElaboratedConfiguredPackage, BuildFailurePresentation)]
1228     failuresClassification =
1229       [ (pkg, classifyBuildFailure failure)
1230       | (pkgid, failure) <- failures
1231       , case buildFailureReason failure of
1232           DependentFailed{} -> verbosity > normal
1233           _ -> True
1234       , InstallPlan.Configured pkg <-
1235           maybeToList (InstallPlan.lookup plan pkgid)
1236       ]
1237
1238     dieIfNotHaddockFailure :: Verbosity -> String -> IO ()
1239     dieIfNotHaddockFailure verb str
1240       | currentCommand == HaddockCommand = dieWithException verb $ DieIfNotHaddockFailureException str
1241       | all isHaddockFailure failuresClassification = warn verb str
1242       | otherwise = dieWithException verb $ DieIfNotHaddockFailureException str
1243       where
1244         isHaddockFailure
1245           (_, ShowBuildSummaryOnly (HaddocksFailed _)) = True
1246         isHaddockFailure
1247           (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True
1248         isHaddockFailure
1249           _ = False
1250
1251     classifyBuildFailure :: BuildFailure -> BuildFailurePresentation
1252     classifyBuildFailure
1253       BuildFailure
1254         { buildFailureReason = reason
1255         , buildFailureLogFile = mlogfile
1256         } =
1257         maybe
1258           (ShowBuildSummaryOnly reason)
1259           (ShowBuildSummaryAndLog reason)
1260           $ do
1261             logfile <- mlogfile
1262             e <- buildFailureException reason
1263             ExitFailure 1 <- fromException e
1264             return logfile
1265
1266     -- Special case: we don't want to report anything complicated in the case
1267     -- of just doing build on the current package, since it's clear from
1268     -- context which package failed.
1269     --
1270     -- We generalise this rule as follows:
1271     --  - if only one failure occurs, and it is in a single root
1272     --    package (i.e. a package with nothing else depending on it)
1273     --  - and that failure is of a kind that always reports enough
1274     --    detail itself (e.g. ghc reporting errors on stdout)
1275     --  - then we do not report additional error detail or context.
1276     --
1277     isSimpleCase :: Bool
1278     isSimpleCase
1279       | [(pkgid, failure)] <- failures
1280       , [pkg] <- rootpkgs
1281       , installedUnitId pkg == pkgid
1282       , isFailureSelfExplanatory (buildFailureReason failure)
1283       , currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] =
1284           True
1285       | otherwise =
1286           False
1287
1288     -- NB: if the Setup script segfaulted or was interrupted,
1289     -- we should give more detailed information.  So only
1290     -- assume that exit code 1 is "pedestrian failure."
1291     isFailureSelfExplanatory :: BuildFailureReason -> Bool
1292     isFailureSelfExplanatory (BuildFailed e)
1293       | Just (ExitFailure 1) <- fromException e = True
1294     isFailureSelfExplanatory (ConfigureFailed e)
1295       | Just (ExitFailure 1) <- fromException e = True
1296     isFailureSelfExplanatory _ = False
1297
1298     rootpkgs :: [ElaboratedConfiguredPackage]
1299     rootpkgs =
1300       [ pkg
1301       | InstallPlan.Configured pkg <- InstallPlan.toList plan
1302       , hasNoDependents pkg
1303       ]
1304
1305     ultimateDeps
1306       :: UnitId
1307       -> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage]
1308     ultimateDeps pkgid =
1309       filter
1310         (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)
1311         (InstallPlan.reverseDependencyClosure plan [pkgid])
1312
1313     hasNoDependents :: HasUnitId pkg => pkg -> Bool
1314     hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId
1315
1316     renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
1317     renderFailureDetail mentionDepOf pkg reason =
1318       renderFailureSummary mentionDepOf pkg reason
1319         ++ "."
1320         ++ renderFailureExtraDetail reason
1321         ++ maybe "" showException (buildFailureException reason)
1322
1323     renderFailureSummary :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
1324     renderFailureSummary mentionDepOf pkg reason =
1325       case reason of
1326         DownloadFailed _ -> "Failed to download " ++ pkgstr
1327         UnpackFailed _ -> "Failed to unpack " ++ pkgstr
1328         ConfigureFailed _ -> "Failed to build " ++ pkgstr
1329         BuildFailed _ -> "Failed to build " ++ pkgstr
1330         ReplFailed _ -> "repl failed for " ++ pkgstr
1331         HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr
1332         TestsFailed _ -> "Tests failed for " ++ pkgstr
1333         BenchFailed _ -> "Benchmarks failed for " ++ pkgstr
1334         InstallFailed _ -> "Failed to build " ++ pkgstr
1335         GracefulFailure msg -> msg
1336         DependentFailed depid ->
1337           "Failed to build "
1338             ++ prettyShow (packageId pkg)
1339             ++ " because it depends on "
1340             ++ prettyShow depid
1341             ++ " which itself failed to build"
1342       where
1343         pkgstr =
1344           elabConfiguredName verbosity pkg
1345             ++ if mentionDepOf
1346               then renderDependencyOf (installedUnitId pkg)
1347               else ""
1348
1349     renderFailureExtraDetail :: BuildFailureReason -> String
1350     renderFailureExtraDetail (ConfigureFailed _) =
1351       " The failure occurred during the configure step."
1352     renderFailureExtraDetail (InstallFailed _) =
1353       " The failure occurred during the final install step."
1354     renderFailureExtraDetail _ =
1355       ""
1356
1357     renderDependencyOf :: UnitId -> String
1358     renderDependencyOf pkgid =
1359       case ultimateDeps pkgid of
1360         [] -> ""
1361         (p1 : []) ->
1362           " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")"
1363         (p1 : p2 : []) ->
1364           " (which is required by "
1365             ++ elabPlanPackageName verbosity p1
1366             ++ " and "
1367             ++ elabPlanPackageName verbosity p2
1368             ++ ")"
1369         (p1 : p2 : _) ->
1370           " (which is required by "
1371             ++ elabPlanPackageName verbosity p1
1372             ++ ", "
1373             ++ elabPlanPackageName verbosity p2
1374             ++ " and others)"
1375
1376     showException e = case fromException e of
1377       Just (ExitFailure 1) -> ""
1378
1379 {- FOURMOLU_DISABLE -}
1380 #ifdef MIN_VERSION_unix
1381       -- Note [Positive "signal" exit code]
1382       -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1383       -- What's the business with the test for negative and positive
1384       -- signal values?  The API for process specifies that if the
1385       -- process died due to a signal, it returns a *negative* exit
1386       -- code.  So that's the negative test.
1387       --
1388       -- What about the positive test?  Well, when we find out that
1389       -- a process died due to a signal, we ourselves exit with that
1390       -- exit code.  However, we don't "kill ourselves" with the
1391       -- signal; we just exit with the same code as the signal: thus
1392       -- the caller sees a *positive* exit code.  So that's what
1393       -- happens when we get a positive exit code.
1394       Just (ExitFailure n)
1395         | -n == fromIntegral sigSEGV ->
1396             " The build process segfaulted (i.e. SIGSEGV)."
1397
1398         |  n == fromIntegral sigSEGV ->
1399             " The build process terminated with exit code " ++ show n
1400          ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)."
1401
1402         | -n == fromIntegral sigKILL ->
1403             " The build process was killed (i.e. SIGKILL). " ++ explanation
1404
1405         |  n == fromIntegral sigKILL ->
1406             " The build process terminated with exit code " ++ show n
1407          ++ " which may be because some part of it was killed "
1408          ++ "(i.e. SIGKILL). " ++ explanation
1409         where
1410           explanation =
1411             "The typical reason for this is that there is not "
1412             ++ "enough memory available (e.g. the OS killed a process "
1413             ++ "using lots of memory)."
1414 #endif
1415       Just (ExitFailure n) ->
1416         " The build process terminated with exit code " ++ show n
1417
1418       _ -> " The exception was:\n  "
1419              ++ displayException e
1420
1421     buildFailureException :: BuildFailureReason -> Maybe SomeException
1422     buildFailureException reason =
1423       case reason of
1424         DownloadFailed  e -> Just e
1425         UnpackFailed    e -> Just e
1426         ConfigureFailed e -> Just e
1427         BuildFailed     e -> Just e
1428         ReplFailed      e -> Just e
1429         HaddocksFailed  e -> Just e
1430         TestsFailed     e -> Just e
1431         BenchFailed     e -> Just e
1432         InstallFailed   e -> Just e
1433         GracefulFailure _ -> Nothing
1434         DependentFailed _ -> Nothing
1435 {- FOURMOLU_ENABLE -}
1436
1437 data BuildFailurePresentation
1438   = ShowBuildSummaryOnly BuildFailureReason
1439   | ShowBuildSummaryAndLog BuildFailureReason FilePath
1440
1441 -------------------------------------------------------------------------------
1442 -- Dummy projects
1443 -------------------------------------------------------------------------------
1444
1445 -- | Create a dummy project context, without a .cabal or a .cabal.project file
1446 -- (a place where to put a temporary dist directory is still needed)
1447 establishDummyProjectBaseContext
1448   :: Verbosity
1449   -> ProjectConfig
1450   -- ^ Project configuration including the global config if needed
1451   -> DistDirLayout
1452   -- ^ Where to put the dist directory
1453   -> [PackageSpecifier UnresolvedSourcePackage]
1454   -- ^ The packages to be included in the project
1455   -> CurrentCommand
1456   -> IO ProjectBaseContext
1457 establishDummyProjectBaseContext verbosity projectConfig distDirLayout localPackages currentCommand = do
1458   let ProjectConfigBuildOnly
1459         { projectConfigLogsDir
1460         } = projectConfigBuildOnly projectConfig
1461
1462       ProjectConfigShared
1463         { projectConfigStoreDir
1464         } = projectConfigShared projectConfig
1465
1466       mlogsDir = flagToMaybe projectConfigLogsDir
1467       mstoreDir = flagToMaybe projectConfigStoreDir
1468
1469   cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
1470
1471   let buildSettings :: BuildTimeSettings
1472       buildSettings =
1473         resolveBuildTimeSettings
1474           verbosity
1475           cabalDirLayout
1476           projectConfig
1477       installedPackages = Nothing
1478
1479   return
1480     ProjectBaseContext
1481       { distDirLayout
1482       , cabalDirLayout
1483       , projectConfig
1484       , localPackages
1485       , buildSettings
1486       , currentCommand
1487       , installedPackages
1488       }
1489
1490 establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout
1491 establishDummyDistDirLayout verbosity cliConfig tmpDir = do
1492   let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing
1493
1494   -- Create the dist directories
1495   createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout
1496   createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout
1497
1498   return distDirLayout
1499   where
1500     mdistDirectory =
1501       flagToMaybe $
1502         projectConfigDistDir $
1503           projectConfigShared cliConfig
1504     projectRoot = ProjectRootImplicit tmpDir