ProjectOrchestration.hs 28.9 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}

-- | This module deals with building and incrementally rebuilding a collection
-- of packages. It is what backs the @cabal build@ and @configure@ commands,
-- as well as being a core part of @run@, @test@, @bench@ and others. 
--
-- The primary thing is in fact rebuilding (and trying to make that quick by
-- not redoing unnecessary work), so building from scratch is just a special
-- case.
--
-- The build process and the code can be understood by breaking it down into
-- three major parts:
--
-- * The 'ElaboratedInstallPlan' type
--
-- * The \"what to do\" phase, where we look at the all input configuration
--   (project files, .cabal files, command line etc) and produce a detailed
--   plan of what to do -- the 'ElaboratedInstallPlan'.
--
-- * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we
-- re-execute it.
--
-- As far as possible, the \"what to do\" phase embodies all the policy, leaving
-- the \"do it\" phase policy free. The first phase contains more of the
-- complicated logic, but it is contained in code that is either pure or just
-- has read effects (except cache updates). Then the second phase does all the
-- actions to build packages, but as far as possible it just follows the
-- instructions and avoids any logic for deciding what to do (apart from
-- recompilation avoidance in executing the plan).
--
-- This division helps us keep the code under control, making it easier to
-- understand, test and debug. So when you are extending these modules, please
-- think about which parts of your change belong in which part. It is
-- perfectly ok to extend the description of what to do (i.e. the 
-- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the
-- first phase. Also, the second phase does not have direct access to any of
-- the input configuration anyway; all the information has to flow via the
-- 'ElaboratedInstallPlan'.
--
module Distribution.Client.ProjectOrchestration (
    -- * Pre-build phase: decide what to do.
    runProjectPreBuildPhase,
    CliConfigFlags,
    PreBuildHooks(..),
    ProjectBuildContext(..),

    -- ** Adjusting the plan
    selectTargets,
    printPlan,

    -- * Build phase: now do it.
    runProjectBuildPhase,
54
55
56

    -- * Post build actions
    reportBuildFailures,
57
58
59
60
  ) where

import           Distribution.Client.ProjectConfig
import           Distribution.Client.ProjectPlanning
61
import           Distribution.Client.ProjectPlanning.Types
62
63
64
import           Distribution.Client.ProjectBuilding

import           Distribution.Client.Types
65
                   ( GenericReadyPackage(..), PackageLocation(..) )
66
67
68
69
70
71
72
73
import qualified Distribution.Client.InstallPlan as InstallPlan
import           Distribution.Client.BuildTarget
                   ( UserBuildTarget, resolveUserBuildTargets
                   , BuildTarget(..), buildTargetPackage )
import           Distribution.Client.DistDirLayout
import           Distribution.Client.Config (defaultCabalDir)
import           Distribution.Client.Setup hiding (packageName)

74
75
import           Distribution.Solver.Types.OptionalStanza

76
77
78
79
80
81
import           Distribution.Package
                   hiding (InstalledPackageId, installedPackageId)
import qualified Distribution.PackageDescription as PD
import           Distribution.PackageDescription (FlagAssignment)
import           Distribution.Simple.Setup (HaddockFlags)

82
import           Distribution.Simple.Utils (die, notice, noticeNoWrap, debug)
83
84
85
86
87
88
import           Distribution.Verbosity
import           Distribution.Text

import qualified Data.Set as Set
import qualified Data.Map as Map
import           Data.Map (Map)
89
import qualified Data.ByteString.Lazy.Char8 as BS
90
import           Data.List
91
import           Data.Maybe
92
import           Data.Either
93
import           Control.Exception (Exception(..), throwIO)
94
95
import           System.Exit (ExitCode(..), exitFailure)
#ifdef MIN_VERSION_unix
96
import           System.Posix.Signals (sigKILL, sigSEGV)
97
#endif
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116


-- | Command line configuration flags. These are used to extend\/override the
-- project configuration.
--
type CliConfigFlags = ( GlobalFlags
                      , ConfigFlags, ConfigExFlags
                      , InstallFlags, HaddockFlags )

-- | Hooks to alter the behaviour of 'runProjectPreBuildPhase'.
--
-- For example the @configure@, @build@ and @repl@ commands use this to get
-- their different behaviour.
--
data PreBuildHooks = PreBuildHooks {
       hookPrePlanning      :: FilePath
                            -> DistDirLayout
                            -> ProjectConfig
                            -> IO (),
117
118
       hookSelectPlanSubset :: BuildTimeSettings
                            -> ElaboratedInstallPlan
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
                            -> IO ElaboratedInstallPlan
     }

-- | This holds the context between the pre-build and build phases.
--
data ProjectBuildContext = ProjectBuildContext {
      distDirLayout    :: DistDirLayout,
      elaboratedPlan   :: ElaboratedInstallPlan,
      elaboratedShared :: ElaboratedSharedConfig,
      pkgsBuildStatus  :: BuildStatusMap,
      buildSettings    :: BuildTimeSettings
    }


-- | Pre-build phase: decide what to do.
--
runProjectPreBuildPhase :: Verbosity
                        -> CliConfigFlags
                        -> PreBuildHooks
                        -> IO ProjectBuildContext
runProjectPreBuildPhase
    verbosity
    ( globalFlags
    , configFlags, configExFlags
    , installFlags, haddockFlags )
    PreBuildHooks{..} = do

    cabalDir <- defaultCabalDir
    let cabalDirLayout = defaultCabalDirLayout cabalDir

    projectRootDir <- findProjectRoot
    let distDirLayout = defaultDistDirLayout projectRootDir

    let cliConfig = commandLineFlagsToProjectConfig
                      globalFlags configFlags configExFlags
                      installFlags haddockFlags

    hookPrePlanning
      projectRootDir
      distDirLayout
      cliConfig

    -- Take the project configuration and make a plan for how to build
    -- everything in the project. This is independent of any specific targets
    -- the user has asked for.
    --
165
    (elaboratedPlan, _, elaboratedShared, projectConfig) <-
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
      rebuildInstallPlan verbosity
                         projectRootDir distDirLayout cabalDirLayout
                         cliConfig

    let buildSettings = resolveBuildTimeSettings
                          verbosity cabalDirLayout
                          (projectConfigShared    projectConfig)
                          (projectConfigBuildOnly projectConfig)
                          (projectConfigBuildOnly cliConfig)

    -- The plan for what to do is represented by an 'ElaboratedInstallPlan'

    -- Now given the specific targets the user has asked for, decide
    -- which bits of the plan we will want to execute.
    --
181
    elaboratedPlan' <- hookSelectPlanSubset buildSettings elaboratedPlan
182
183
184
185
186

    -- Check if any packages don't need rebuilding, and improve the plan.
    -- This also gives us more accurate reasons for the --dry-run output.
    --
    (elaboratedPlan'', pkgsBuildStatus) <-
187
      rebuildTargetsDryRun verbosity distDirLayout elaboratedShared
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
                           elaboratedPlan'

    return ProjectBuildContext {
      distDirLayout,
      elaboratedPlan = elaboratedPlan'',
      elaboratedShared,
      pkgsBuildStatus,
      buildSettings
    }


-- | Build phase: now do it.
--
-- Execute all or parts of the description of what to do to build or
-- rebuild the various packages needed.
--
runProjectBuildPhase :: Verbosity
                     -> ProjectBuildContext
206
                     -> IO BuildOutcomes
207
runProjectBuildPhase verbosity ProjectBuildContext {..} =
208
    fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $
209
210
211
212
213
214
    rebuildTargets verbosity
                   distDirLayout
                   elaboratedPlan
                   elaboratedShared
                   pkgsBuildStatus
                   buildSettings
215
  where
216
217
    previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes
    previousBuildOutcomes =
218
      Map.mapMaybe $ \status -> case status of
219
        BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess)
220
221
        --TODO: [nice to have] record build failures persistently
        _                                  -> Nothing
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246

    -- Note that it is a deliberate design choice that the 'buildTargets' is
    -- not passed to phase 1, and the various bits of input config is not
    -- passed to phase 2.
    --
    -- We make the install plan without looking at the particular targets the
    -- user asks us to build. The set of available things we can build is
    -- discovered from the env and config and is used to make the install plan.
    -- The targets just tell us which parts of the install plan to execute.
    --
    -- Conversely, executing the plan does not directly depend on any of the
    -- input config. The bits that are needed (or better, the decisions based
    -- on it) all go into the install plan.

    -- Notionally, the 'BuildFlags' should be things that do not affect what
    -- we build, just how we do it. These ones of course do 


------------------------------------------------------------------------------
-- Taking targets into account, selecting what to build
--

-- | Adjust an 'ElaboratedInstallPlan' by selecting just those parts of it
-- required to build the given user targets.
--
247
248
249
-- How to get the 'PackageTarget's from the 'UserBuildTarget' is customisable,
-- so that we can change the meaning of @pkgname@ to target a build or
-- repl depending on which command is calling it.
250
--
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
-- Conceptually, every target identifies one or more roots in the
-- 'ElaboratedInstallPlan', which we then use to determine the closure
-- of what packages need to be built, dropping everything from
-- 'ElaboratedInstallPlan' that is unnecessary.
--
-- There is a complication, however: In an ideal world, every
-- possible target would be a node in the graph.  However, it is
-- currently not possible (and possibly not even desirable) to invoke a
-- Setup script to build *just* one file.  Similarly, it is not possible
-- to invoke a pre Cabal-1.25 custom Setup script and build only one
-- component.  In these cases, we want to build the entire package, BUT
-- only actually building some of the files/components.  This is what
-- 'pkgBuildTargets', 'pkgReplTarget' and 'pkgBuildHaddock' control.
-- Arguably, these should an out-of-band mechanism rather than stored
-- in 'ElaboratedInstallPlan', but it's what we have.  We have
-- to fiddle around with the ElaboratedConfiguredPackage roots to say
-- what it will build.
--
selectTargets :: Verbosity -> PackageTarget
270
271
              -> (ComponentTarget -> PackageTarget)
              -> [UserBuildTarget]
272
              -> Bool
273
274
              -> ElaboratedInstallPlan
              -> IO ElaboratedInstallPlan
275
selectTargets verbosity targetDefaultComponents targetSpecificComponent
276
              userBuildTargets onlyDependencies installPlan = do
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301

    -- Match the user targets against the available targets. If no targets are
    -- given this uses the package in the current directory, if any.
    --
    buildTargets <- resolveUserBuildTargets localPackages userBuildTargets
    --TODO: [required eventually] report something if there are no targets

    --TODO: [required eventually]
    -- we cannot resolve names of packages other than those that are
    -- directly in the current plan. We ought to keep a set of the known
    -- hackage packages so we can resolve names to those. Though we don't
    -- really need that until we can do something sensible with packages
    -- outside of the project.

    -- Now check if those targets belong to the current project or not.
    -- Ultimately we want to do something sensible for targets not in this
    -- project, but for now we just bail. This gives us back the ipkgid from
    -- the plan.
    --
    buildTargets' <- either reportBuildTargetProblems return
                   $ resolveAndCheckTargets
                       targetDefaultComponents
                       targetSpecificComponent
                       installPlan
                       buildTargets
302
    debug verbosity ("buildTargets': " ++ show buildTargets')
303
304

    -- Finally, prune the install plan to cover just those target packages
305
    -- and their deps (or only their deps with the --only-dependencies flag).
306
    --
307
308
    let installPlan' = pruneInstallPlanToTargets
                         buildTargets' installPlan
309
    if onlyDependencies
310
311
312
313
      then either throwIO return $
             pruneInstallPlanToDependencies
               (Map.keysSet buildTargets') installPlan'
      else return installPlan'
314
315
  where
    localPackages =
316
317
      [ (elabPkgDescription elab, elabPkgSourceLocation elab)
      | InstallPlan.Configured elab <- InstallPlan.toList installPlan ]
318
319
320
321
322
323
324
325
326
      --TODO: [code cleanup] is there a better way to identify local packages?



resolveAndCheckTargets :: PackageTarget
                       -> (ComponentTarget -> PackageTarget)
                       -> ElaboratedInstallPlan
                       -> [BuildTarget PackageName]
                       -> Either [BuildTargetProblem]
327
                                 (Map UnitId [PackageTarget])
328
329
330
331
332
resolveAndCheckTargets targetDefaultComponents
                       targetSpecificComponent
                       installPlan targets =
    case partitionEithers (map checkTarget targets) of
      ([], targets') -> Right $ Map.fromListWith (++)
333
334
                                  [ (uid, [t]) | (uids, t) <- targets'
                                               , uid <- uids ]
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
      (problems, _)  -> Left problems
  where
    -- TODO [required eventually] currently all build targets refer to packages
    -- inside the project. Ultimately this has to be generalised to allow
    -- referring to other packages and targets.

    -- We can ask to build any whole package, project-local or a dependency
    checkTarget (BuildTargetPackage pn)
      | Just ipkgid <- Map.lookup pn projAllPkgs
      = Right (ipkgid, targetDefaultComponents)

    -- But if we ask to build an individual component, then that component
    -- had better be in a package that is local to the project.
    -- TODO: and if it's an optional stanza, then that stanza must be available
    checkTarget t@(BuildTargetComponent pn cn)
      | Just ipkgid <- Map.lookup pn projLocalPkgs
      = Right (ipkgid, targetSpecificComponent
                         (ComponentTarget cn WholeComponent))

      | Map.member pn projAllPkgs
      = Left (BuildTargetComponentNotProjectLocal t)

    checkTarget t@(BuildTargetModule pn cn mn)
      | Just ipkgid <- Map.lookup pn projLocalPkgs
      = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (ModuleTarget mn)))

      | Map.member pn projAllPkgs
      = Left (BuildTargetComponentNotProjectLocal t)

    checkTarget t@(BuildTargetFile pn cn fn)
      | Just ipkgid <- Map.lookup pn projLocalPkgs
      = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (FileTarget fn)))

      | Map.member pn projAllPkgs
      = Left (BuildTargetComponentNotProjectLocal t)

    checkTarget t
      = Left (BuildTargetNotInProject (buildTargetPackage t))


375
376
377
    -- NB: It's a list of 'InstalledPackageId', because each component
    -- in the install plan from a single package needs to be associated with
    -- the same 'PackageName'.
378
    projAllPkgs, projLocalPkgs :: Map PackageName [UnitId]
379
    projAllPkgs =
380
      Map.fromListWith (++)
381
        [ (packageName pkg, [installedUnitId pkg])
382
383
384
        | pkg <- InstallPlan.toList installPlan ]

    projLocalPkgs =
385
      Map.fromListWith (++)
386
387
388
        [ (packageName elab, [installedUnitId elab])
        | InstallPlan.Configured elab <- InstallPlan.toList installPlan
        , case elabPkgSourceLocation elab of
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
            LocalUnpackedPackage _ -> True; _ -> False
          --TODO: [code cleanup] is there a better way to identify local packages?
        ]

    --TODO: [research required] what if the solution has multiple versions of this package?
    --      e.g. due to setup deps or due to multiple independent sets of
    --      packages being built (e.g. ghc + ghcjs in a project)

data BuildTargetProblem
   = BuildTargetNotInProject PackageName
   | BuildTargetComponentNotProjectLocal (BuildTarget PackageName)
   | BuildTargetOptionalStanzaDisabled Bool
      -- ^ @True@: explicitly disabled by user
      -- @False@: disabled by solver

reportBuildTargetProblems :: [BuildTargetProblem] -> IO a
reportBuildTargetProblems = die . unlines . map reportBuildTargetProblem

reportBuildTargetProblem :: BuildTargetProblem -> String
reportBuildTargetProblem (BuildTargetNotInProject pn) =
        "Cannot build the package " ++ display pn ++ ", it is not in this project."
     ++ "(either directly or indirectly). If you want to add it to the "
     ++ "project then edit the cabal.project file."

reportBuildTargetProblem (BuildTargetComponentNotProjectLocal t) =
        "The package " ++ display (buildTargetPackage t) ++ " is in the "
     ++ "project but it is not a locally unpacked package, so  "

reportBuildTargetProblem (BuildTargetOptionalStanzaDisabled _) = undefined


------------------------------------------------------------------------------
-- Displaying what we plan to do
--

-- | Print a user-oriented presentation of the install plan, indicating what
-- will be built.
--
printPlan :: Verbosity -> ProjectBuildContext -> IO ()
printPlan verbosity
          ProjectBuildContext {
            elaboratedPlan,
            pkgsBuildStatus,
            buildSettings = BuildTimeSettings{buildSettingDryRun}
          }

  | null pkgs
  = notice verbosity "Up to date"

438
439
440
441
  | otherwise
  = noticeNoWrap verbosity $ unlines $
      ("In order, the following " ++ wouldWill ++ " be built" ++
      ifNormal " (use -v for more details)" ++ ":")
442
443
444
    : map showPkgAndReason pkgs

  where
445
    pkgs = InstallPlan.executionOrder elaboratedPlan
446

447
448
449
450
451
452
    ifVerbose s | verbosity >= verbose = s
                | otherwise            = ""

    ifNormal s | verbosity >= verbose = ""
               | otherwise            = s

453
454
455
456
    wouldWill | buildSettingDryRun = "would"
              | otherwise          = "will"

    showPkgAndReason :: ElaboratedReadyPackage -> String
457
    showPkgAndReason (ReadyPackage elab) =
458
459
460
461
462
      " - " ++
      (if verbosity >= verbose
        then display (installedUnitId elab)
        else display (packageId elab)
        ) ++
463
      (case elabPkgOrComp elab of
464
          ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg)
465
          ElabComponent comp ->
466
467
            " (" ++ maybe "custom" display (compComponentName comp) ++ ")"
            ) ++
468
469
      showFlagAssignment (nonDefaultFlags elab) ++
      let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in
470
471
      " (" ++ showBuildStatus buildStatus ++ ")"

472
473
    nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment
    nonDefaultFlags elab = elabFlagAssignment elab \\ elabFlagDefaults elab
474
475
476
477
478
479
480

    showStanzas pkg = concat
                    $ [ " *test"
                      | TestStanzas  `Set.member` pkgStanzasEnabled pkg ]
                   ++ [ " *bench"
                      | BenchStanzas `Set.member` pkgStanzasEnabled pkg ]

481
482
    showTargets elab
      | null (elabBuildTargets elab) = ""
483
      | otherwise
484
      = " (" ++ intercalate ", " [ showComponentTarget (packageId elab) t | t <- elabBuildTargets elab ]
485
486
487
488
489
490
491
492
493
494
             ++ ")"

    -- TODO: [code cleanup] this should be a proper function in a proper place
    showFlagAssignment :: FlagAssignment -> String
    showFlagAssignment = concatMap ((' ' :) . showFlagValue)
    showFlagValue (f, True)   = '+' : showFlagName f
    showFlagValue (f, False)  = '-' : showFlagName f
    showFlagName (PD.FlagName f) = f

    showBuildStatus status = case status of
495
496
      BuildStatusPreExisting -> "existing package"
      BuildStatusInstalled   -> "already installed"
497
498
499
500
501
502
503
504
505
506
507
508
509
510
      BuildStatusDownload {} -> "requires download & build"
      BuildStatusUnpack   {} -> "requires build"
      BuildStatusRebuild _ rebuild -> case rebuild of
        BuildStatusConfigure
          (MonitoredValueChanged _)   -> "configuration changed"
        BuildStatusConfigure mreason  -> showMonitorChangedReason mreason
        BuildStatusBuild _ buildreason -> case buildreason of
          BuildReasonDepsRebuilt      -> "dependency rebuilt"
          BuildReasonFilesChanged
            mreason                   -> showMonitorChangedReason mreason
          BuildReasonExtraTargets _   -> "additional components to build"
          BuildReasonEphemeralTargets -> "ephemeral targets"
      BuildStatusUpToDate {} -> "up to date" -- doesn't happen

511
    showMonitorChangedReason (MonitoredFileChanged file) = "file " ++ file ++ " changed"
512
513
514
515
516
    showMonitorChangedReason (MonitoredValueChanged _)   = "value changed"
    showMonitorChangedReason  MonitorFirstRun     = "first run"
    showMonitorChangedReason  MonitorCorruptCache = "cannot read state cache"


517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
reportBuildFailures :: Verbosity -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()
reportBuildFailures verbosity plan buildOutcomes
  | null failures = return ()

  | isSimpleCase  = exitFailure

  | otherwise = do
      -- For failures where we have a build log, print the log plus a header
       sequence_
         [ do notice verbosity $
                '\n' : renderFailureDetail False pkg reason
                    ++ "\nBuild log ( " ++ logfile ++ " ):"
              BS.readFile logfile >>= BS.putStrLn
         | verbosity >= normal
         ,  (pkg, ShowBuildSummaryAndLog reason logfile)
             <- failuresClassification
         ]

       -- For all failures, print either a short summary (if we showed the
       -- build log) or all details
       die $ unlines
         [ case failureClassification of
             ShowBuildSummaryAndLog reason _
               | verbosity > normal
              -> renderFailureDetail mentionDepOf pkg reason

               | otherwise
              -> renderFailureSummary mentionDepOf pkg reason
545
              ++ ". See the build log above for details."
546
547
548
549
550
551

             ShowBuildSummaryOnly reason ->
               renderFailureDetail mentionDepOf pkg reason

         | let mentionDepOf = verbosity <= normal
         , (pkg, failureClassification) <- failuresClassification ]
552
  where
553
554
    failures =  [ (pkgid, failure)
                | (pkgid, Left failure) <- Map.toList buildOutcomes ]
555

556
557
    failuresClassification =
      [ (pkg, classifyBuildFailure failure)
558
559
      | (pkgid, failure) <- failures
      , case buildFailureReason failure of
560
          DependentFailed {} -> verbosity > normal
561
562
563
564
565
          _                  -> True
      , InstallPlan.Configured pkg <-
           maybeToList (InstallPlan.lookup plan pkgid)
      ]

566
567
568
569
570
571
572
573
574
575
576
577
    classifyBuildFailure :: BuildFailure -> BuildFailurePresentation
    classifyBuildFailure BuildFailure {
                           buildFailureReason  = reason,
                           buildFailureLogFile = mlogfile
                         } =
      maybe (ShowBuildSummaryOnly   reason)
            (ShowBuildSummaryAndLog reason) $ do
        logfile <- mlogfile
        e       <- buildFailureException reason
        ExitFailure 1 <- fromException e
        return logfile

578
579
580
581
582
583
584
585
586
587
588
589
    -- Special case: we don't want to report anything complicated in the case
    -- of just doing build on the current package, since it's clear from
    -- context which package failed.
    --
    -- We generalise this rule as follows:
    --  - if only one failure occurs, and it is in a single root package (ie a
    --    package with nothing else depending on it)
    --  - and that failure is of a kind that always reports enough detail
    --    itself (e.g. ghc reporting errors on stdout)
    --  - then we do not report additional error detail or context.
    --
    isSimpleCase
590
591
      | [(pkgid, failure)] <- failures
      , [pkg]              <- rootpkgs
592
      , installedUnitId pkg == pkgid
593
      , isFailureSelfExplanatory (buildFailureReason failure)
594
595
596
597
      = True
      | otherwise
      = False

598
599
600
    -- NB: if the Setup script segfaulted or was interrupted,
    -- we should give more detailed information.  So only
    -- assume that exit code 1 is "pedestrian failure."
601
    isFailureSelfExplanatory (BuildFailed e)
602
      | Just (ExitFailure 1) <- fromException e = True
603

604
    isFailureSelfExplanatory (ConfigureFailed e)
605
      | Just (ExitFailure 1) <- fromException e = True
606

607
    isFailureSelfExplanatory _                  = False
608
609
610
611
612
613
614
615
616
617
618
619
620

    rootpkgs =
      [ pkg
      | InstallPlan.Configured pkg <- InstallPlan.toList plan
      , hasNoDependents pkg ]

    ultimateDeps pkgid =
        filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)
               (InstallPlan.reverseDependencyClosure plan [pkgid])

    hasNoDependents :: HasUnitId pkg => pkg -> Bool
    hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId

621
622
623
624
625
626
    renderFailureDetail mentionDepOf pkg reason =
        renderFailureSummary mentionDepOf pkg reason ++ "."
     ++ renderFailureExtraDetail reason
     ++ maybe "" showException (buildFailureException reason)

    renderFailureSummary mentionDepOf pkg reason =
627
        case reason of
628
629
630
631
632
633
634
635
636
637
638
639
          DownloadFailed  _ -> "Failed to download " ++ pkgstr
          UnpackFailed    _ -> "Failed to unpack "   ++ pkgstr
          ConfigureFailed _ -> "Failed to build "    ++ pkgstr
          BuildFailed     _ -> "Failed to build "    ++ pkgstr
          ReplFailed      _ -> "repl failed for "    ++ pkgstr
          HaddocksFailed  _ -> "Failed to build documentation for " ++ pkgstr
          TestsFailed     _ -> "Tests failed for " ++ pkgstr
          InstallFailed   _ -> "Failed to build "  ++ pkgstr
          DependentFailed depid
                            -> "Failed to build " ++ display (packageId pkg)
                            ++ " because it depends on " ++ display depid
                            ++ " which itself failed to build"
640
641
      where
        pkgstr = display (packageId pkg)
642
643
644
645
646
647
648
649
650
              ++ if mentionDepOf
                   then renderDependencyOf (installedUnitId pkg)
                   else ""

    renderFailureExtraDetail reason =
      case reason of
        ConfigureFailed _ -> " The failure occurred during the configure step."
        InstallFailed   _ -> " The failure occurred during the final install step."
        _                 -> ""
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665

    renderDependencyOf pkgid =
      case ultimateDeps pkgid of
        []         -> ""
        (p1:[])    -> " (which is required by " ++ display (packageName p1) ++ ")"
        (p1:p2:[]) -> " (which is required by " ++ display (packageName p1)
                                     ++ " and " ++ display (packageName p2) ++ ")"
        (p1:p2:_)  -> " (which is required by " ++ display (packageName p1)
                                        ++ ", " ++ display (packageName p2)
                                        ++ " and others)"

    showException e = case fromException e of
      Just (ExitFailure 1) -> ""

#ifdef MIN_VERSION_unix
666
667
668
669
670
671
672
673
674
675
676
677
678
      -- Note [Positive "signal" exit code]
      -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      -- What's the business with the test for negative and positive
      -- signal values?  The API for process specifies that if the
      -- process died due to a signal, it returns a *negative* exit
      -- code.  So that's the negative test.
      --
      -- What about the positive test?  Well, when we find out that
      -- a process died due to a signal, we ourselves exit with that
      -- exit code.  However, we don't "kill ourselves" with the
      -- signal; we just exit with the same code as the signal: thus
      -- the caller sees a *positive* exit code.  So that's what
      -- happens when we get a positive exit code.
679
      Just (ExitFailure n)
680
681
682
683
684
685
686
        | -n == fromIntegral sigSEGV ->
            " The build process segfaulted (i.e. SIGSEGV)."

        |  n == fromIntegral sigSEGV ->
            " The build process terminated with exit code " ++ show n
         ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)."

687
688
689
690
691
692
693
694
695
        | -n == fromIntegral sigKILL ->
            " The build process was killed (i.e. SIGKILL). " ++ explanation

        |  n == fromIntegral sigKILL ->
            " The build process terminated with exit code " ++ show n
         ++ " which may be because some part of it was killed "
         ++ "(i.e. SIGKILL). " ++ explanation
        where
          explanation = "The typical reason for this is that there is not "
696
                     ++ "enough memory available (e.g. the OS killed a process "
697
698
699
700
701
702
703
704
705
706
707
                     ++ "using lots of memory)."
#endif
      Just (ExitFailure n) ->
        " The build process terminated with exit code " ++ show n

      _ -> " The exception was:\n  "
#if MIN_VERSION_base(4,8,0)
             ++ displayException e
#else
             ++ show e
#endif
708

709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
    buildFailureException reason =
      case reason of
        DownloadFailed  e -> Just e
        UnpackFailed    e -> Just e
        ConfigureFailed e -> Just e
        BuildFailed     e -> Just e
        ReplFailed      e -> Just e
        HaddocksFailed  e -> Just e
        TestsFailed     e -> Just e
        InstallFailed   e -> Just e
        DependentFailed _ -> Nothing

data BuildFailurePresentation =
       ShowBuildSummaryOnly   BuildFailureReason
     | ShowBuildSummaryAndLog BuildFailureReason FilePath