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