ProjectBuilding.hs 51.2 KB
Newer Older
Duncan Coutts's avatar
Duncan Coutts committed
1
2
{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns,
             ScopedTypeVariables #-}
3
4
5
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE ConstraintKinds #-}
Duncan Coutts's avatar
Duncan Coutts committed
6

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
7
-- |
Duncan Coutts's avatar
Duncan Coutts committed
8
9
--
module Distribution.Client.ProjectBuilding (
10
    -- * Dry run phase
11
12
13
14
15
16
17
    -- | What bits of the plan will we execute? The dry run does not change
    -- anything but tells us what will need to be built.
    rebuildTargetsDryRun,
    improveInstallPlanWithUpToDatePackages,

    -- ** Build status
    -- | This is the detailed status information we get from the dry run.
Duncan Coutts's avatar
Duncan Coutts committed
18
    BuildStatusMap,
19
    BuildStatus(..),
Duncan Coutts's avatar
Duncan Coutts committed
20
21
22
    BuildStatusRebuild(..),
    BuildReason(..),
    MonitorChangedReason(..),
23
    buildStatusToString,
24
25

    -- * Build phase
26
27
28
29
30
    -- | Now we actually execute the plan.
    rebuildTargets,
    -- ** Build outcomes
    -- | This is the outcome for each package of executing the plan.
    -- For each package, did the build succeed or fail?
31
    BuildOutcomes,
32
    BuildOutcome,
33
    BuildResult(..),
34
    BuildFailure(..),
35
    BuildFailureReason(..),
Duncan Coutts's avatar
Duncan Coutts committed
36
37
38
39
40
41
  ) where

import           Distribution.Client.PackageHash (renderPackageHashInputs)
import           Distribution.Client.RebuildMonad
import           Distribution.Client.ProjectConfig
import           Distribution.Client.ProjectPlanning
42
import           Distribution.Client.ProjectPlanning.Types
43
import           Distribution.Client.ProjectBuilding.Types
Duncan Coutts's avatar
Duncan Coutts committed
44
45

import           Distribution.Client.Types
46
47
                   hiding (BuildOutcomes, BuildOutcome,
                           BuildResult(..), BuildFailure(..))
Duncan Coutts's avatar
Duncan Coutts committed
48
import           Distribution.Client.InstallPlan
49
                   ( GenericInstallPlan, GenericPlanPackage, IsUnit )
Duncan Coutts's avatar
Duncan Coutts committed
50
51
52
53
54
55
56
57
58
import qualified Distribution.Client.InstallPlan as InstallPlan
import           Distribution.Client.DistDirLayout
import           Distribution.Client.FileMonitor
import           Distribution.Client.SetupWrapper
import           Distribution.Client.JobControl
import           Distribution.Client.FetchUtils
import           Distribution.Client.GlobalFlags (RepoContext)
import qualified Distribution.Client.Tar as Tar
import           Distribution.Client.Setup (filterConfigureFlags)
59
import           Distribution.Client.SrcDist (allPackageSourceFiles)
Duncan Coutts's avatar
Duncan Coutts committed
60
61
62
63
64
65
66
67
68
69
70
import           Distribution.Client.Utils (removeExistingFile)

import           Distribution.Package hiding (InstalledPackageId, installedPackageId)
import           Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as Installed
import           Distribution.Simple.Program
import qualified Distribution.Simple.Setup as Cabal
import           Distribution.Simple.Command (CommandUI)
import qualified Distribution.Simple.Register as Cabal
import qualified Distribution.Simple.InstallDirs as InstallDirs
import           Distribution.Simple.LocalBuildInfo (ComponentName)
71
import qualified Distribution.Simple.Program.HcPkg as HcPkg
Duncan Coutts's avatar
Duncan Coutts committed
72
73
74
75
76
77

import           Distribution.Simple.Utils hiding (matchFileGlob)
import           Distribution.Version
import           Distribution.Verbosity
import           Distribution.Text
import           Distribution.ParseUtils ( showPWarning )
78
import           Distribution.Compat.Graph (IsNode(..))
Duncan Coutts's avatar
Duncan Coutts committed
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100

import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as LBS

import           Control.Monad
import           Control.Exception
import           Data.List
import           Data.Maybe

import           System.FilePath
import           System.IO
import           System.Directory


------------------------------------------------------------------------------
-- * Overall building strategy.
------------------------------------------------------------------------------
--
-- We start with an 'ElaboratedInstallPlan' that has already been improved by
101
102
-- reusing packages from the store, and pruned to include only the targets of
-- interest and their dependencies. So the remaining packages in the
Duncan Coutts's avatar
Duncan Coutts committed
103
104
105
106
107
-- 'InstallPlan.Configured' state are ones we either need to build or rebuild.
--
-- First, we do a preliminary dry run phase where we work out which packages
-- we really need to (re)build, and for the ones we do need to build which
-- build phase to start at.
108
109
110
111
112
113
114
115
116
117
118
119
--
-- We use this to improve the 'ElaboratedInstallPlan' again by changing
-- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed'
-- so that the build phase will skip them.
--
-- Then we execute the plan, that is actually build packages. The outcomes of
-- trying to build all the packages are collected and returned.
--
-- We split things like this (dry run and execute) for a couple reasons.
-- Firstly we need to be able to do dry runs anyway, and these need to be
-- reasonably accurate in terms of letting users know what (and why) things
-- are going to be (re)built.
Duncan Coutts's avatar
Duncan Coutts committed
120
121
122
123
124
125
126
127
128
129
130
131
132
--
-- Given that we need to be able to do dry runs, it would not be great if
-- we had to repeat all the same work when we do it for real. Not only is
-- it duplicate work, but it's duplicate code which is likely to get out of
-- sync. So we do things only once. We preserve info we discover in the dry
-- run phase and rely on it later when we build things for real. This also
-- somewhat simplifies the build phase. So this way the dry run can't so
-- easily drift out of sync with the real thing since we're relying on the
-- info it produces.
--
-- An additional advantage is that it makes it easier to debug rebuild
-- errors (ie rebuilding too much or too little), since all the rebuild
-- decisions are made without making any state changes at the same time
133
-- (that would make it harder to reproduce the problem situation).
134
135
136
137
138
139
140
141
--
-- Finally, we can use the dry run build status and the build outcomes to
-- give us some information on the overall status of packages in the project.
-- This includes limited information about the status of things that were
-- not actually in the subset of the plan that was used for the dry run or
-- execution phases. In particular we may know that some packages are now
-- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for
-- details.
Duncan Coutts's avatar
Duncan Coutts committed
142
143


144
145
146
147
------------------------------------------------------------------------------
-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?
------------------------------------------------------------------------------

148
-- Refer to ProjectBuilding.Types for details of these important types:
Duncan Coutts's avatar
Duncan Coutts committed
149

150
151
152
153
-- type BuildStatusMap     = ...
-- data BuildStatus        = ...
-- data BuildStatusRebuild = ...
-- data BuildReason        = ...
Duncan Coutts's avatar
Duncan Coutts committed
154
155
156

-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.
--
157
158
-- It gives us the 'BuildStatusMap'. This should be used with
-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of
Duncan Coutts's avatar
Duncan Coutts committed
159
160
161
-- the 'ElaboratedInstallPlan' with packages switched to the
-- 'InstallPlan.Installed' state when we find that they're already up to date.
--
162
rebuildTargetsDryRun :: DistDirLayout
163
                     -> ElaboratedSharedConfig
Duncan Coutts's avatar
Duncan Coutts committed
164
                     -> ElaboratedInstallPlan
165
166
                     -> IO BuildStatusMap
rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
Duncan Coutts's avatar
Duncan Coutts committed
167
    -- Do the various checks to work out the 'BuildStatus' of each package
168
    foldMInstallPlanDepOrder dryRunPkg
Duncan Coutts's avatar
Duncan Coutts committed
169
170
  where
    dryRunPkg :: ElaboratedPlanPackage
171
              -> [BuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
172
173
174
175
              -> IO BuildStatus
    dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
      return BuildStatusPreExisting

176
    dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =
177
      return BuildStatusInstalled
178

Duncan Coutts's avatar
Duncan Coutts committed
179
    dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
180
      mloc <- checkFetched (elabPkgSourceLocation pkg)
Duncan Coutts's avatar
Duncan Coutts committed
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
      case mloc of
        Nothing -> return BuildStatusDownload

        Just (LocalUnpackedPackage srcdir) ->
          -- For the case of a user-managed local dir, irrespective of the
          -- build style, we build from that directory and put build
          -- artifacts under the shared dist directory.
          dryRunLocalPkg pkg depsBuildStatus srcdir

        -- The three tarball cases are handled the same as each other,
        -- though depending on the build style.
        Just (LocalTarballPackage    tarball) ->
          dryRunTarballPkg pkg depsBuildStatus tarball

        Just (RemoteTarballPackage _ tarball) ->
          dryRunTarballPkg pkg depsBuildStatus tarball

        Just (RepoTarballPackage _ _ tarball) ->
          dryRunTarballPkg pkg depsBuildStatus tarball

    dryRunTarballPkg :: ElaboratedConfiguredPackage
202
                     -> [BuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
203
204
205
                     -> FilePath
                     -> IO BuildStatus
    dryRunTarballPkg pkg depsBuildStatus tarball =
206
      case elabBuildStyle pkg of
Duncan Coutts's avatar
Duncan Coutts committed
207
208
209
210
211
212
213
214
215
216
217
        BuildAndInstall  -> return (BuildStatusUnpack tarball)
        BuildInplaceOnly -> do
          -- TODO: [nice to have] use a proper file monitor rather than this dir exists test
          exists <- doesDirectoryExist srcdir
          if exists
            then dryRunLocalPkg pkg depsBuildStatus srcdir
            else return (BuildStatusUnpack tarball)
      where
        srcdir = distUnpackedSrcDirectory (packageId pkg)

    dryRunLocalPkg :: ElaboratedConfiguredPackage
218
                   -> [BuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
219
220
221
222
223
224
225
226
227
228
229
230
231
                   -> FilePath
                   -> IO BuildStatus
    dryRunLocalPkg pkg depsBuildStatus srcdir = do
        -- Go and do lots of I/O, reading caches and probing files to work out
        -- if anything has changed
        change <- checkPackageFileMonitorChanged
                    packageFileMonitor pkg srcdir depsBuildStatus
        case change of
          -- It did change, giving us 'BuildStatusRebuild' info on why
          Left rebuild ->
            return (BuildStatusRebuild srcdir rebuild)

          -- No changes, the package is up to date. Use the saved build results.
232
233
          Right buildResult ->
            return (BuildStatusUpToDate buildResult)
Duncan Coutts's avatar
Duncan Coutts committed
234
235
      where
        packageFileMonitor =
236
          newPackageFileMonitor distDirLayout (elabDistDirParams shared pkg)
Duncan Coutts's avatar
Duncan Coutts committed
237
238
239
240
241


-- | A specialised traversal over the packages in an install plan.
--
-- The packages are visited in dependency order, starting with packages with no
242
-- dependencies. The result for each package is accumulated into a 'Map' and
Duncan Coutts's avatar
Duncan Coutts committed
243
244
-- returned as the final result. In addition, when visting a package, the
-- visiting function is passed the results for all the immediate package
245
-- dependencies. This can be used to propagate information from dependencies.
Duncan Coutts's avatar
Duncan Coutts committed
246
247
--
foldMInstallPlanDepOrder
248
  :: forall m ipkg srcpkg b.
249
     (Monad m, IsUnit ipkg, IsUnit srcpkg)
250
  => (GenericPlanPackage ipkg srcpkg ->
251
      [b] -> m b)
252
  -> GenericInstallPlan ipkg srcpkg
253
  -> m (Map UnitId b)
254
255
foldMInstallPlanDepOrder visit =
    go Map.empty . InstallPlan.reverseTopologicalOrder
Duncan Coutts's avatar
Duncan Coutts committed
256
  where
257
    go :: Map UnitId b
258
       -> [GenericPlanPackage ipkg srcpkg]
259
       -> m (Map UnitId b)
Duncan Coutts's avatar
Duncan Coutts committed
260
261
262
263
    go !results [] = return results

    go !results (pkg : pkgs) = do
      -- we go in the right order so the results map has entries for all deps
264
      let depresults :: [b]
Duncan Coutts's avatar
Duncan Coutts committed
265
          depresults =
266
267
            map (\ipkgid -> let Just result = Map.lookup ipkgid results
                              in result)
268
                (InstallPlan.depends pkg)
Duncan Coutts's avatar
Duncan Coutts committed
269
      result <- visit pkg depresults
270
      let results' = Map.insert (nodeKey pkg) result results
Duncan Coutts's avatar
Duncan Coutts committed
271
272
      go results' pkgs

273
improveInstallPlanWithUpToDatePackages :: BuildStatusMap
Duncan Coutts's avatar
Duncan Coutts committed
274
                                       -> ElaboratedInstallPlan
275
276
277
                                       -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
    InstallPlan.installed canPackageBeImproved
Duncan Coutts's avatar
Duncan Coutts committed
278
  where
279
280
281
282
283
284
    canPackageBeImproved pkg =
      case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
        Just BuildStatusUpToDate {} -> True
        Just _                      -> False
        Nothing -> error $ "improveInstallPlanWithUpToDatePackages: "
                        ++ display (packageId pkg) ++ " not in status map"
Duncan Coutts's avatar
Duncan Coutts committed
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302


-----------------------------
-- Package change detection
--

-- | As part of the dry run for local unpacked packages we have to check if the
-- package config or files have changed. That is the purpose of
-- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'.
--
-- When a package is (re)built, the monitor must be updated to reflect the new
-- state of the package. Because we sometimes build without reconfiguring the
-- state updates are split into two, one for package config changes and one
-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor'
-- and 'updatePackageBuildFileMonitor'.
--
data PackageFileMonitor = PackageFileMonitor {
       pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (),
303
       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildResultMisc,
304
       pkgFileMonitorReg    :: FileMonitor () (Maybe InstalledPackageInfo)
Duncan Coutts's avatar
Duncan Coutts committed
305
306
     }

307
-- | This is all the components of the 'BuildResult' other than the
308
309
-- @['InstalledPackageInfo']@.
--
310
-- We have to split up the 'BuildResult' components since they get produced
311
312
-- at different times (or rather, when different things change).
--
313
type BuildResultMisc = (DocsResult, TestsResult)
314

315
316
newPackageFileMonitor :: DistDirLayout -> DistDirParams -> PackageFileMonitor
newPackageFileMonitor DistDirLayout{distPackageCacheFile} dparams =
Duncan Coutts's avatar
Duncan Coutts committed
317
318
    PackageFileMonitor {
      pkgFileMonitorConfig =
319
        newFileMonitor (distPackageCacheFile dparams "config"),
Duncan Coutts's avatar
Duncan Coutts committed
320
321
322

      pkgFileMonitorBuild =
        FileMonitor {
323
          fileMonitorCacheFile = distPackageCacheFile dparams "build",
Duncan Coutts's avatar
Duncan Coutts committed
324
325
326
327
328
329
          fileMonitorKeyValid  = \componentsToBuild componentsAlreadyBuilt ->
            componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,
          fileMonitorCheckIfOnlyValueChanged = True
        },

      pkgFileMonitorReg =
330
        newFileMonitor (distPackageCacheFile dparams "registration")
Duncan Coutts's avatar
Duncan Coutts committed
331
332
333
334
335
336
337
338
339
340
    }

-- | Helper function for 'checkPackageFileMonitorChanged',
-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'.
--
-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by
-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes.
--
packageFileMonitorKeyValues :: ElaboratedConfiguredPackage
                            -> (ElaboratedConfiguredPackage, Set ComponentName)
341
342
packageFileMonitorKeyValues elab =
    (elab_config, buildComponents)
Duncan Coutts's avatar
Duncan Coutts committed
343
344
345
346
347
348
349
350
  where
    -- The first part is the value used to guard (re)configuring the package.
    -- That is, if this value changes then we will reconfigure.
    -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of
    -- information that affects the (re)configure step. But those parts that
    -- do not affect the configure step need to be nulled out. Those parts are
    -- the specific targets that we're going to build.
    --
351
352
353
354
355
356
    elab_config =
        elab {
            elabBuildTargets = [],
            elabReplTarget    = Nothing,
            elabBuildHaddocks = False
        }
Duncan Coutts's avatar
Duncan Coutts committed
357
358
359
360
361

    -- The second part is the value used to guard the build step. So this is
    -- more or less the opposite of the first part, as it's just the info about
    -- what targets we're going to build.
    --
362
    buildComponents = elabBuildTargetWholeComponents elab
Duncan Coutts's avatar
Duncan Coutts committed
363
364
365
366
367
368
369

-- | Do all the checks on whether a package has changed and thus needs either
-- rebuilding or reconfiguring and rebuilding.
--
checkPackageFileMonitorChanged :: PackageFileMonitor
                               -> ElaboratedConfiguredPackage
                               -> FilePath
370
                               -> [BuildStatus]
371
                               -> IO (Either BuildStatusRebuild BuildResult)
Duncan Coutts's avatar
Duncan Coutts committed
372
373
374
375
376
377
378
379
380
381
382
383
384
385
checkPackageFileMonitorChanged PackageFileMonitor{..}
                               pkg srcdir depsBuildStatus = do
    --TODO: [nice to have] some debug-level message about file changes, like rerunIfChanged
    configChanged <- checkFileMonitorChanged
                       pkgFileMonitorConfig srcdir pkgconfig
    case configChanged of
      MonitorChanged monitorReason ->
          return (Left (BuildStatusConfigure monitorReason'))
        where
          monitorReason' = fmap (const ()) monitorReason

      MonitorUnchanged () _
          -- The configChanged here includes the identity of the dependencies,
          -- so depsBuildStatus is just needed for the changes in the content
386
          -- of dependencies.
387
        | any buildStatusRequiresBuild depsBuildStatus -> do
Duncan Coutts's avatar
Duncan Coutts committed
388
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
            regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()
            let mreg = changedToMaybe regChanged
            return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))

        | otherwise -> do
            buildChanged  <- checkFileMonitorChanged
                               pkgFileMonitorBuild srcdir buildComponents
            regChanged    <- checkFileMonitorChanged
                               pkgFileMonitorReg srcdir ()
            let mreg = changedToMaybe regChanged
            case (buildChanged, regChanged) of
              (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) ->
                  return (Left (BuildStatusBuild mreg buildReason))
                where
                  buildReason = BuildReasonExtraTargets prevBuildComponents

              (MonitorChanged monitorReason, _) ->
                  return (Left (BuildStatusBuild mreg buildReason))
                where
                  buildReason    = BuildReasonFilesChanged monitorReason'
                  monitorReason' = fmap (const ()) monitorReason

              (MonitorUnchanged _ _, MonitorChanged monitorReason) ->
                -- this should only happen if the file is corrupt or been
                -- manually deleted. We don't want to bother with another
                -- phase just for this, so we'll reregister by doing a build.
                  return (Left (BuildStatusBuild Nothing buildReason))
                where
                  buildReason    = BuildReasonFilesChanged monitorReason'
                  monitorReason' = fmap (const ()) monitorReason

              (MonitorUnchanged _ _, MonitorUnchanged _ _)
                | pkgHasEphemeralBuildTargets pkg ->
                  return (Left (BuildStatusBuild mreg buildReason))
                where
                  buildReason = BuildReasonEphemeralTargets

425
              (MonitorUnchanged buildResult _, MonitorUnchanged _ _) ->
426
427
428
                  return $ Right BuildResult {
                    buildResultDocs    = docsResult,
                    buildResultTests   = testsResult,
429
                    buildResultLogFile = Nothing
430
                  }
431
                where
432
                  (docsResult, testsResult) = buildResult
Duncan Coutts's avatar
Duncan Coutts committed
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
  where
    (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
    changedToMaybe (MonitorChanged     _) = Nothing
    changedToMaybe (MonitorUnchanged x _) = Just x


updatePackageConfigFileMonitor :: PackageFileMonitor
                               -> FilePath
                               -> ElaboratedConfiguredPackage
                               -> IO ()
updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig}
                               srcdir pkg =
    updateFileMonitor pkgFileMonitorConfig srcdir Nothing
                      [] pkgconfig ()
  where
    (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg

updatePackageBuildFileMonitor :: PackageFileMonitor
                              -> FilePath
                              -> MonitorTimestamp
                              -> ElaboratedConfiguredPackage
                              -> BuildStatusRebuild
                              -> [FilePath]
456
                              -> BuildResultMisc
Duncan Coutts's avatar
Duncan Coutts committed
457
458
459
                              -> IO ()
updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}
                              srcdir timestamp pkg pkgBuildStatus
460
                              allSrcFiles buildResult =
Duncan Coutts's avatar
Duncan Coutts committed
461
    updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)
462
                      (map monitorFileHashed allSrcFiles)
463
                      buildComponents' buildResult
Duncan Coutts's avatar
Duncan Coutts committed
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
  where
    (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg

    -- If the only thing that's changed is that we're now building extra
    -- components, then we can avoid later unnecessary rebuilds by saving the
    -- total set of components that have been built, namely the union of the
    -- existing ones plus the new ones. If files also changed this would be
    -- the wrong thing to do. Note that we rely on the
    -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee
    -- that it's /only/ the value that changed not any files that changed.
    buildComponents' =
      case pkgBuildStatus of
        BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents)
          -> buildComponents `Set.union` prevBuildComponents
        _ -> buildComponents

updatePackageRegFileMonitor :: PackageFileMonitor
                            -> FilePath
482
                            -> Maybe InstalledPackageInfo
Duncan Coutts's avatar
Duncan Coutts committed
483
484
                            -> IO ()
updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg}
485
                            srcdir mipkg =
Duncan Coutts's avatar
Duncan Coutts committed
486
    updateFileMonitor pkgFileMonitorReg srcdir Nothing
487
                      [] () mipkg
Duncan Coutts's avatar
Duncan Coutts committed
488
489
490
491
492
493
494
495
496
497

invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
    removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)


------------------------------------------------------------------------------
-- * Doing it: executing an 'ElaboratedInstallPlan'
------------------------------------------------------------------------------

498
-- Refer to ProjectBuilding.Types for details of these important types:
499

500
501
502
503
504
-- type BuildOutcomes = ...
-- type BuildOutcome  = ...
-- data BuildResult   = ...
-- data BuildFailure  = ...
-- data BuildFailureReason = ...
505

Duncan Coutts's avatar
Duncan Coutts committed
506
507
-- | Build things for real.
--
Edward Z. Yang's avatar
Edward Z. Yang committed
508
-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.
Duncan Coutts's avatar
Duncan Coutts committed
509
510
511
512
513
514
515
--
rebuildTargets :: Verbosity
               -> DistDirLayout
               -> ElaboratedInstallPlan
               -> ElaboratedSharedConfig
               -> BuildStatusMap
               -> BuildTimeSettings
516
               -> IO BuildOutcomes
Duncan Coutts's avatar
Duncan Coutts committed
517
518
519
rebuildTargets verbosity
               distDirLayout@DistDirLayout{..}
               installPlan
520
521
522
523
               sharedPackageConfig@ElaboratedSharedConfig {
                 pkgConfigCompiler      = compiler,
                 pkgConfigCompilerProgs = progdb
               }
Duncan Coutts's avatar
Duncan Coutts committed
524
               pkgsBuildStatus
525
526
527
528
               buildSettings@BuildTimeSettings{
                 buildSettingNumJobs,
                 buildSettingKeepGoing
               } = do
Duncan Coutts's avatar
Duncan Coutts committed
529
530
531

    -- Concurrency control: create the job controller and concurrency limits
    -- for downloading, building and installing.
532
533
534
    jobControl    <- if isParallelBuild
                       then newParallelJobControl buildSettingNumJobs
                       else newSerialJobControl
535
    registerLock  <- newLock -- serialise registration
Duncan Coutts's avatar
Duncan Coutts committed
536
537
538
    cacheLock     <- newLock -- serialise access to setup exe cache
                             --TODO: [code cleanup] eliminate setup exe cache

539
540
    createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
    createDirectoryIfMissingVerbose verbosity True distTempDirectory
541
    mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
Duncan Coutts's avatar
Duncan Coutts committed
542
543
544
545
546
547
548

    -- Before traversing the install plan, pre-emptively find all packages that
    -- will need to be downloaded and start downloading them.
    asyncDownloadPackages verbosity withRepoCtx
                          installPlan pkgsBuildStatus $ \downloadMap ->

      -- For each package in the plan, in dependency order, but in parallel...
549
550
      InstallPlan.execute jobControl keepGoing
                          (BuildFailure Nothing . DependentFailed . packageId)
551
                          installPlan $ \pkg ->
552
553
        --TODO: review exception handling
        handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $
Duncan Coutts's avatar
Duncan Coutts committed
554

555
556
        let uid = installedUnitId pkg
            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in
Duncan Coutts's avatar
Duncan Coutts committed
557
558
559
560
561

        rebuildTarget
          verbosity
          distDirLayout
          buildSettings downloadMap
562
          registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
563
564
565
566
567
          sharedPackageConfig
          pkg
          pkgBuildStatus
  where
    isParallelBuild = buildSettingNumJobs >= 2
568
    keepGoing       = buildSettingKeepGoing
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
569
    withRepoCtx     = projectConfigWithBuilderRepoContext verbosity
Duncan Coutts's avatar
Duncan Coutts committed
570
                        buildSettings
571
572
573
    packageDBsToUse = -- all the package dbs we may need to create
      (Set.toList . Set.fromList)
        [ pkgdb
574
575
576
577
        | InstallPlan.Configured elab <- InstallPlan.toList installPlan
        , (pkgdb:_) <- map reverse [ elabBuildPackageDBStack elab,
                                     elabRegisterPackageDBStack elab,
                                     elabSetupPackageDBStack elab ]
578
        ]
Duncan Coutts's avatar
Duncan Coutts committed
579
580
581
582
583
584

-- | Given all the context and resources, (re)build an individual package.
--
rebuildTarget :: Verbosity
              -> DistDirLayout
              -> BuildTimeSettings
Duncan Coutts's avatar
Duncan Coutts committed
585
              -> AsyncFetchMap
586
              -> Lock -> Lock
Duncan Coutts's avatar
Duncan Coutts committed
587
588
589
              -> ElaboratedSharedConfig
              -> ElaboratedReadyPackage
              -> BuildStatus
590
              -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
591
592
593
rebuildTarget verbosity
              distDirLayout@DistDirLayout{distBuildDirectory}
              buildSettings downloadMap
594
              registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
595
              sharedPackageConfig
596
              rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
597
598
599
600
601
602
603
604
605
606
              pkgBuildStatus =

    -- We rely on the 'BuildStatus' to decide which phase to start from:
    case pkgBuildStatus of
      BuildStatusDownload              -> downloadPhase
      BuildStatusUnpack tarball        -> unpackTarballPhase tarball
      BuildStatusRebuild srcdir status -> rebuildPhase status srcdir

      -- TODO: perhaps re-nest the types to make these impossible
      BuildStatusPreExisting {} -> unexpectedState
607
      BuildStatusInstalled   {} -> unexpectedState
Duncan Coutts's avatar
Duncan Coutts committed
608
609
610
611
612
      BuildStatusUpToDate    {} -> unexpectedState
  where
    unexpectedState = error "rebuildTarget: unexpected package status"

    downloadPhase = do
613
        downsrcloc <- annotateFailureNoLog DownloadFailed $
614
                        waitAsyncPackageDownload verbosity downloadMap pkg
Duncan Coutts's avatar
Duncan Coutts committed
615
616
617
618
619
620
621
622
        case downsrcloc of
          DownloadedTarball tarball -> unpackTarballPhase tarball
          --TODO: [nice to have] git/darcs repos etc


    unpackTarballPhase tarball =
        withTarballLocalDirectory
          verbosity distDirLayout tarball
623
624
          (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg)
          (elabPkgDescriptionOverride pkg) $
Duncan Coutts's avatar
Duncan Coutts committed
625

626
          case elabBuildStyle pkg of
Duncan Coutts's avatar
Duncan Coutts committed
627
628
629
630
631
632
633
634
635
636
            BuildAndInstall  -> buildAndInstall
            BuildInplaceOnly -> buildInplace buildStatus
              where
                buildStatus = BuildStatusConfigure MonitorFirstRun

    -- Note that this really is rebuild, not build. It can only happen for
    -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages
    -- would only start from download or unpack phases.
    --
    rebuildPhase buildStatus srcdir =
637
        assert (elabBuildStyle pkg == BuildInplaceOnly) $
Duncan Coutts's avatar
Duncan Coutts committed
638
639
640

          buildInplace buildStatus srcdir builddir
      where
641
        builddir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg)
Duncan Coutts's avatar
Duncan Coutts committed
642
643
644
645

    buildAndInstall srcdir builddir =
        buildAndInstallUnpackedPackage
          verbosity distDirLayout
646
          buildSettings registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
647
648
649
650
651
652
653
654
655
656
657
          sharedPackageConfig
          rpkg
          srcdir builddir'
      where
        builddir' = makeRelative srcdir builddir
        --TODO: [nice to have] ^^ do this relative stuff better

    buildInplace buildStatus srcdir builddir =
        --TODO: [nice to have] use a relative build dir rather than absolute
        buildInplaceUnpackedPackage
          verbosity distDirLayout
658
          buildSettings registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
          sharedPackageConfig
          rpkg
          buildStatus
          srcdir builddir

--TODO: [nice to have] do we need to use a with-style for the temp files for downloading http
-- packages, or are we going to cache them persistently?

-- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the
-- packages we have to download and fork off an async action to download them.
-- We download them in dependency order so that the one's we'll need
-- first are the ones we will start downloading first.
--
-- The body action is passed a map from those packages (identified by their
-- location) to a completion var for that package. So the body action should
-- lookup the location and use 'waitAsyncPackageDownload' to get the result.
--
asyncDownloadPackages :: Verbosity
Duncan Coutts's avatar
Duncan Coutts committed
677
                      -> ((RepoContext -> IO a) -> IO a)
Duncan Coutts's avatar
Duncan Coutts committed
678
679
                      -> ElaboratedInstallPlan
                      -> BuildStatusMap
Duncan Coutts's avatar
Duncan Coutts committed
680
                      -> (AsyncFetchMap -> IO a)
Duncan Coutts's avatar
Duncan Coutts committed
681
682
683
                      -> IO a
asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
  | null pkgsToDownload = body Map.empty
Duncan Coutts's avatar
Duncan Coutts committed
684
685
686
  | otherwise           = withRepoCtx $ \repoctx ->
                            asyncFetchPackages verbosity repoctx
                                               pkgsToDownload body
Duncan Coutts's avatar
Duncan Coutts committed
687
  where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
688
    pkgsToDownload =
689
      ordNub $
690
691
      [ elabPkgSourceLocation elab
      | InstallPlan.Configured elab
Duncan Coutts's avatar
Duncan Coutts committed
692
         <- InstallPlan.reverseTopologicalOrder installPlan
693
      , let uid = installedUnitId elab
694
            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus
Duncan Coutts's avatar
Duncan Coutts committed
695
696
697
698
699
      , BuildStatusDownload <- [pkgBuildStatus]
      ]


-- | Check if a package needs downloading, and if so expect to find a download
Duncan Coutts's avatar
Duncan Coutts committed
700
-- in progress in the given 'AsyncFetchMap' and wait on it to finish.
Duncan Coutts's avatar
Duncan Coutts committed
701
702
--
waitAsyncPackageDownload :: Verbosity
Duncan Coutts's avatar
Duncan Coutts committed
703
                         -> AsyncFetchMap
Duncan Coutts's avatar
Duncan Coutts committed
704
705
                         -> ElaboratedConfiguredPackage
                         -> IO DownloadedSourceLocation
706
waitAsyncPackageDownload verbosity downloadMap elab = do
Duncan Coutts's avatar
Duncan Coutts committed
707
    pkgloc <- waitAsyncFetchPackage verbosity downloadMap
708
                                    (elabPkgSourceLocation elab)
Duncan Coutts's avatar
Duncan Coutts committed
709
710
711
712
713
714
715
716
717
718
719
720
721
722
    case downloadedSourceLocation pkgloc of
      Just loc -> return loc
      Nothing  -> fail "waitAsyncPackageDownload: unexpected source location"

data DownloadedSourceLocation = DownloadedTarball FilePath
                              --TODO: [nice to have] git/darcs repos etc

downloadedSourceLocation :: PackageLocation FilePath
                         -> Maybe DownloadedSourceLocation
downloadedSourceLocation pkgloc =
    case pkgloc of
      RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)
      RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)
      _                              -> Nothing
Duncan Coutts's avatar
Duncan Coutts committed
723
724
725
726
727




-- | Ensure that the package is unpacked in an appropriate directory, either
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
728
-- a temporary one or a persistent one under the shared dist directory.
Duncan Coutts's avatar
Duncan Coutts committed
729
730
731
732
733
734
--
withTarballLocalDirectory
  :: Verbosity
  -> DistDirLayout
  -> FilePath
  -> PackageId
735
  -> DistDirParams
Duncan Coutts's avatar
Duncan Coutts committed
736
737
  -> BuildStyle
  -> Maybe CabalFileText
738
739
740
  -> (FilePath -> -- Source directory
      FilePath -> -- Build directory
      IO a)
Duncan Coutts's avatar
Duncan Coutts committed
741
742
  -> IO a
withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}
743
                          tarball pkgid dparams buildstyle pkgTextOverride
Duncan Coutts's avatar
Duncan Coutts committed
744
745
                          buildPkg  =
      case buildstyle of
746
747
748
        -- In this case we make a couple temp dirs, unpack the tarball to one
        -- and build and install it from the other. We avoid nesting the
        -- builddir under the tarball src dir to keep path name lengths down.
Duncan Coutts's avatar
Duncan Coutts committed
749
        BuildAndInstall ->
750
751
752
753
          let tmpdir = distTempDirectory in
          withTempDirectory verbosity tmpdir "src"   $ \unpackdir ->
          withTempDirectory verbosity tmpdir "build" $ \builddir -> do
            unpackPackageTarball verbosity tarball unpackdir
Duncan Coutts's avatar
Duncan Coutts committed
754
                                 pkgid pkgTextOverride
755
            let srcdir   = unpackdir </> display pkgid
Duncan Coutts's avatar
Duncan Coutts committed
756
757
758
759
760
761
762
763
            buildPkg srcdir builddir

        -- In this case we make sure the tarball has been unpacked to the
        -- appropriate location under the shared dist dir, and then build it
        -- inplace there
        BuildInplaceOnly -> do
          let srcrootdir = distUnpackedSrcRootDirectory
              srcdir     = distUnpackedSrcDirectory pkgid
764
              builddir   = distBuildDirectory dparams
Duncan Coutts's avatar
Duncan Coutts committed
765
766
767
          -- TODO: [nice to have] use a proper file monitor rather than this dir exists test
          exists <- doesDirectoryExist srcdir
          unless exists $ do
768
            createDirectoryIfMissingVerbose verbosity True srcrootdir
Duncan Coutts's avatar
Duncan Coutts committed
769
770
771
            unpackPackageTarball verbosity tarball srcrootdir
                                 pkgid pkgTextOverride
            moveTarballShippedDistDirectory verbosity distDirLayout
772
                                            srcrootdir pkgid dparams
Duncan Coutts's avatar
Duncan Coutts committed
773
774
775
776
777
778
779
780
          buildPkg srcdir builddir


unpackPackageTarball :: Verbosity -> FilePath -> FilePath
                     -> PackageId -> Maybe CabalFileText
                     -> IO ()
unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
    --TODO: [nice to have] switch to tar package and catch tar exceptions
781
    annotateFailureNoLog UnpackFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817

      -- Unpack the tarball
      --
      info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."
      Tar.extractTarGzFile parentdir pkgsubdir tarball

      -- Sanity check
      --
      exists <- doesFileExist cabalFile
      when (not exists) $
        die $ "Package .cabal file not found in the tarball: " ++ cabalFile

      -- Overwrite the .cabal with the one from the index, when appropriate
      --
      case pkgTextOverride of
        Nothing     -> return ()
        Just pkgtxt -> do
          info verbosity $ "Updating " ++ display pkgname <.> "cabal"
                        ++ " with the latest revision from the index."
          writeFileAtomic cabalFile pkgtxt

  where
    cabalFile = parentdir </> pkgsubdir
                          </> display pkgname <.> "cabal"
    pkgsubdir = display pkgid
    pkgname   = packageName pkgid


-- | This is a bit of a hacky workaround. A number of packages ship
-- pre-processed .hs files in a dist directory inside the tarball. We don't
-- use the standard 'dist' location so unless we move this dist dir to the
-- right place then we'll miss the shipped pre-procssed files. This hacky
-- approach to shipped pre-procssed files ought to be replaced by a proper
-- system, though we'll still need to keep this hack for older packages.
--
moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout
818
                                -> FilePath -> PackageId -> DistDirParams -> IO ()
Duncan Coutts's avatar
Duncan Coutts committed
819
moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
820
                                parentdir pkgid dparams = do
Duncan Coutts's avatar
Duncan Coutts committed
821
822
823
824
825
826
827
828
    distDirExists <- doesDirectoryExist tarballDistDir
    when distDirExists $ do
      debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '"
                                   ++ targetDistDir ++ "'"
      --TODO: [nice to have] or perhaps better to copy, and use a file monitor
      renameDirectory tarballDistDir targetDistDir
  where
    tarballDistDir = parentdir </> display pkgid </> "dist"
829
    targetDistDir  = distBuildDirectory dparams
Duncan Coutts's avatar
Duncan Coutts committed
830
831
832
833
834
835
836
837


buildAndInstallUnpackedPackage :: Verbosity
                               -> DistDirLayout
                               -> BuildTimeSettings -> Lock -> Lock
                               -> ElaboratedSharedConfig
                               -> ElaboratedReadyPackage
                               -> FilePath -> FilePath
838
                               -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
839
840
841
842
843
844
buildAndInstallUnpackedPackage verbosity
                               DistDirLayout{distTempDirectory}
                               BuildTimeSettings {
                                 buildSettingNumJobs,
                                 buildSettingLogFile
                               }
845
                               registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
846
                               pkgshared@ElaboratedSharedConfig {
847
848
849
                                 pkgConfigPlatform      = platform,
                                 pkgConfigCompiler      = compiler,
                                 pkgConfigCompilerProgs = progdb
Duncan Coutts's avatar
Duncan Coutts committed
850
                               }
851
                               rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
852
853
                               srcdir builddir = do

854
    createDirectoryIfMissingVerbose verbosity True builddir
Duncan Coutts's avatar
Duncan Coutts committed
855
856
857
858
859
860
861
862
863
864
865
866
    initLogFile

    --TODO: [code cleanup] deal consistently with talking to older Setup.hs versions, much like
    --      we do for ghc, with a proper options type and rendering step
    --      which will also let us call directly into the lib, rather than always
    --      going via the lib's command line interface, which would also allow
    --      passing data like installed packages, compiler, and program db for a
    --      quicker configure.

    --TODO: [required feature] docs and tests
    --TODO: [required feature] sudo re-exec

867
    let dispname = case elabPkgOrComp pkg of
868
            ElabPackage _ -> display pkgid
869
870
871
                ++ " (all, due to Custom setup)"
            ElabComponent comp -> display pkgid
                ++ " (" ++ maybe "custom" display (compComponentName comp) ++ ")"
872

Duncan Coutts's avatar
Duncan Coutts committed
873
874
    -- Configure phase
    when isParallelBuild $
875
      notice verbosity $ "Configuring " ++ dispname ++ "..."
876
    annotateFailure mlogFile ConfigureFailed $
877
      setup' configureCommand configureFlags configureArgs
Duncan Coutts's avatar
Duncan Coutts committed
878
879
880

    -- Build phase
    when isParallelBuild $
881
      notice verbosity $ "Building " ++ dispname ++ "..."
882
    annotateFailure mlogFile BuildFailed $
Duncan Coutts's avatar
Duncan Coutts committed
883
884
885
      setup buildCommand buildFlags

    -- Install phase
886
    annotateFailure mlogFile InstallFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
887
888
889
890
891
892
893
894
895
      --TODO: [required eventually] need to lock installing this ipkig so other processes don't
      -- stomp on our files, since we don't have ABI compat, not safe to replace

      -- TODO: [required eventually] note that for nix-style installations it is not necessary to do
      -- the 'withWin32SelfUpgrade' dance, but it would be necessary for a
      -- shared bin dir.

      -- Actual installation
      setup Cabal.copyCommand copyFlags
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
896

Duncan Coutts's avatar
Duncan Coutts committed
897
      LBS.writeFile
898
        (InstallDirs.prefix (elabInstallDirs pkg) </> "cabal-hash.txt") $
Duncan Coutts's avatar
Duncan Coutts committed
899
900
901
902
903
904
905
906
907
908
        (renderPackageHashInputs (packageHashInputs pkgshared pkg))

      -- here's where we could keep track of the installed files ourselves if
      -- we wanted by calling copy to an image dir and then we would make a
      -- manifest and move it to its final location

      --TODO: [nice to have] we should actually have it make an image in store/incomming and
      -- then when it's done, move it to its final location, to reduce problems
      -- with installs failing half-way. Could also register and then move.

909
      if elabRequiresRegistration pkg
Duncan Coutts's avatar
Duncan Coutts committed
910
911
912
913
        then do
          -- We register ourselves rather than via Setup.hs. We need to
          -- grab and modify the InstalledPackageInfo. We decide what
          -- the installed package id is, not the build system.
914
          ipkg0 <- generateInstalledPackageInfo
915
          let ipkg = ipkg0 { Installed.installedUnitId = uid }
916

917
          criticalSection registerLock $
918
919
              Cabal.registerPackage verbosity compiler progdb
                                    HcPkg.MultiInstance
920
                                    (elabRegisterPackageDBStack pkg) ipkg
921
        else return ()
Duncan Coutts's avatar
Duncan Coutts committed
922
923
924
925
926

    --TODO: [required feature] docs and test phases
    let docsResult  = DocsNotTried
        testsResult = TestsNotTried

927
928
929
    return BuildResult {
       buildResultDocs    = docsResult,
       buildResultTests   = testsResult,
930
       buildResultLogFile = mlogFile
931
    }
Duncan Coutts's avatar
Duncan Coutts committed
932
933
934

  where
    pkgid  = packageId rpkg
935
    uid = installedUnitId rpkg
Duncan Coutts's avatar
Duncan Coutts committed
936
937
938

    isParallelBuild = buildSettingNumJobs >= 2

939
    configureCommand = Cabal.configureCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
940
941
942
    configureFlags v = flip filterConfigureFlags v $
                       setupHsConfigureFlags rpkg pkgshared
                                             verbosity builddir
943
    configureArgs    = setupHsConfigureArgs pkg
Duncan Coutts's avatar
Duncan Coutts committed
944

945
    buildCommand     = Cabal.buildCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
946
947
    buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir

948
949
950
    generateInstalledPackageInfo :: IO InstalledPackageInfo
    generateInstalledPackageInfo =
      withTempInstalledPackageInfoFile
951
        verbosity distTempDirectory $ \pkgConfDest -> do
Duncan Coutts's avatar
Duncan Coutts committed
952
953
954
        let registerFlags _ = setupHsRegisterFlags
                                pkg pkgshared
                                verbosity builddir
955
                                pkgConfDest
Duncan Coutts's avatar
Duncan Coutts committed
956
957
958
959
960
961
962
963
        setup Cabal.registerCommand registerFlags

    copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir

    scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir
                                         isParallelBuild cacheLock

    setup :: CommandUI flags -> (Version -> flags) -> IO ()
964
965
966
967
    setup cmd flags = setup' cmd flags []

    setup' :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()
    setup' cmd flags args =
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
968
      withLogging $ \mLogFileHandle ->
Duncan Coutts's avatar
Duncan Coutts committed
969
970
971
        setupWrapper
          verbosity
          scriptOptions { useLoggingHandle = mLogFileHandle }
972
          (Just (elabPkgDescription pkg))
973
          cmd flags args
Duncan Coutts's avatar
Duncan Coutts committed
974

975
    mlogFile :: Maybe FilePath
Duncan Coutts's avatar
Duncan Coutts committed
976
977
978
    mlogFile =
      case buildSettingLogFile of
        Nothing        -> Nothing
979
        Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
Duncan Coutts's avatar
Duncan Coutts committed
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996

    initLogFile =
      case mlogFile of
        Nothing      -> return ()
        Just logFile -> do
          createDirectoryIfMissing True (takeDirectory logFile)
          exists <- doesFileExist logFile
          when exists $ removeFile logFile

    withLogging action =
      case mlogFile of
        Nothing      -> action Nothing
        Just logFile -> withFile logFile AppendMode (action . Just)


buildInplaceUnpackedPackage :: Verbosity
                            -> DistDirLayout
997
                            -> BuildTimeSettings -> Lock -> Lock
Duncan Coutts's avatar
Duncan Coutts committed
998
999
1000
1001
                            -> ElaboratedSharedConfig
                            -> ElaboratedReadyPackage
                            -> BuildStatusRebuild
                            -> FilePath -> FilePath
1002
                            -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
1003
1004
1005
1006
1007
1008
buildInplaceUnpackedPackage verbosity
                            distDirLayout@DistDirLayout {
                              distTempDirectory,
                              distPackageCacheDirectory
                            }
                            BuildTimeSettings{buildSettingNumJobs}
1009
                            registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
1010
                            pkgshared@ElaboratedSharedConfig {
1011
1012
                              pkgConfigCompiler      = compiler,
                              pkgConfigCompilerProgs = progdb
Duncan Coutts's avatar
Duncan Coutts committed
1013
                            }
1014
                            rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
1015
1016
1017
1018
1019
                            buildStatus
                            srcdir builddir = do

        --TODO: [code cleanup] there is duplication between the distdirlayout and the builddir here
        --      builddir is not enough, we also need the per-package cachedir
1020
1021
        createDirectoryIfMissingVerbose verbosity True builddir
        createDirectoryIfMissingVerbose verbosity True (distPackageCacheDirectory dparams)
Duncan Coutts's avatar
Duncan Coutts committed
1022
1023
1024
1025

        -- Configure phase
        --
        whenReConfigure $ do
1026
          annotateFailureNoLog ConfigureFailed $
1027
            setup configureCommand configureFlags configureArgs
Duncan Coutts's avatar
Duncan Coutts committed
1028
1029
1030
1031
1032
1033
1034
1035
          invalidatePackageRegFileMonitor packageFileMonitor
          updatePackageConfigFileMonitor packageFileMonitor srcdir pkg

        -- Build phase
        --
        let docsResult  = DocsNotTried
            testsResult = TestsNotTried

1036
1037
            buildResult :: BuildResultMisc
            buildResult = (docsResult, testsResult)
Duncan Coutts's avatar
Duncan Coutts committed
1038
1039
1040

        whenRebuild $ do
          timestamp <- beginUpdateFileMonitor
1041
          annotateFailureNoLog BuildFailed $
1042
            setup buildCommand buildFlags buildArgs
Duncan Coutts's avatar
Duncan Coutts committed
1043

1044
1045
1046
          --TODO: [required eventually] this doesn't track file
          --non-existence, so we could fail to rebuild if someone
          --adds a new file which changes behavior.
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
          allSrcFiles <-
            let trySdist    = allPackageSourceFiles verbosity scriptOptions srcdir
                -- This is just a hack, to get semi-reasonable file
                -- listings for the monitor
                tryFallback = do
                    warn verbosity $
                        "Couldn't use sdist to compute source files; falling " ++
                        "back on recursive file scan."
                    filter (not . ("dist" `isPrefixOf`))
                        `fmap` getDirectoryContentsRecursive srcdir
1057
            in if elabSetupScriptCliVersion pkg >= mkVersion [1,17]
1058
1059
1060
1061
1062
                  then do r <- trySdist
                          if null r
                            then tryFallback
                            else return r
                  else tryFallback
Duncan Coutts's avatar
Duncan Coutts committed
1063
1064
1065

          updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp
                                        pkg buildStatus
1066
                                        allSrcFiles buildResult
Duncan Coutts's avatar
Duncan Coutts committed
1067

1068
1069
        -- PURPOSELY omitted: no copy!

1070
        whenReRegister $ annotateFailureNoLog InstallFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
1071
          -- Register locally
1072
          mipkg <- if elabRequiresRegistration pkg
Duncan Coutts's avatar
Duncan Coutts committed
1073
            then do
1074
                ipkg0 <- generateInstalledPackageInfo
Duncan Coutts's avatar
Duncan Coutts committed
1075
1076
1077
                -- We register ourselves rather than via Setup.hs. We need to
                -- grab and modify the InstalledPackageInfo. We decide what
                -- the installed package id is, not the build system.
1078
                let ipkg = ipkg0 { Installed.installedUnitId = ipkgid }
1079
                criticalSection registerLock $
1080
                    Cabal.registerPackage verbosity compiler progdb HcPkg.NoMultiInstance
1081
                                          (elabRegisterPackageDBStack pkg)
1082
1083
                                          ipkg
                return (Just ipkg)
1084

1085
           else return Nothing
1086

1087
          updatePackageRegFileMonitor packageFileMonitor srcdir mipkg
Duncan Coutts's avatar
Duncan Coutts committed
1088
1089
1090
1091

        -- Repl phase
        --
        whenRepl $
1092
          annotateFailureNoLog ReplFailed $
1093
          setupInteractive replCommand replFlags replArgs
Duncan Coutts's avatar
Duncan Coutts committed
1094
1095
1096

        -- Haddock phase
        whenHaddock $
1097
          annotateFailureNoLog HaddocksFailed $
Duncan Coutts's avatar
Duncan Coutts committed
1098
1099
          setup haddockCommand haddockFlags []

1100
1101
1102
        return BuildResult {
          buildResultDocs    = docsResult,
          buildResultTests   = testsResult,
1103
          buildResultLogFile = Nothing
1104
        }
Duncan Coutts's avatar
Duncan Coutts committed
1105
1106

  where
1107
1108
    ipkgid  = installedUnitId pkg
    dparams = elabDistDirParams pkgshared pkg
Duncan Coutts's avatar
Duncan Coutts committed
1109
1110
1111

    isParallelBuild = buildSettingNumJobs >= 2

1112
    packageFileMonitor = newPackageFileMonitor distDirLayout dparams
Duncan Coutts's avatar
Duncan Coutts committed
1113
1114
1115
1116
1117
1118

    whenReConfigure action = case buildStatus of
      BuildStatusConfigure _ -> action
      _                      -> return ()

    whenRebuild action
1119
      | null (elabBuildTargets pkg) = return ()
Duncan Coutts's avatar
Duncan Coutts committed
1120
1121
1122
      | otherwise                  = action

    whenRepl action
1123
      | isNothing (elabReplTarget pkg) = return ()
Duncan Coutts's avatar
Duncan Coutts committed
1124
1125
1126
      | otherwise                     = action

    whenHaddock action
1127
      | elabBuildHaddocks pkg = action
Duncan Coutts's avatar
Duncan Coutts committed
1128
1129
      | otherwise            = return ()

1130
1131
1132
1133
1134
1135
1136
    whenReRegister  action
      = case buildStatus of
          -- We registered the package already
          BuildStatusBuild (Just _) _     -> return ()
          -- There is nothing to register
          _ | null (elabBuildTargets pkg) -> return ()
            | otherwise                   -> action
Duncan Coutts's avatar
Duncan Coutts committed
1137

1138
    configureCommand = Cabal.configureCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
1139
1140
1141
    configureFlags v = flip filterConfigureFlags v $
                       setupHsConfigureFlags rpkg pkgshared
                                             verbosity builddir
1142
    configureArgs    = setupHsConfigureArgs pkg
Duncan Coutts's avatar
Duncan Coutts committed
1143

1144
    buildCommand     = Cabal.buildCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
1145
1146
1147
1148
    buildFlags   _   = setupHsBuildFlags pkg pkgshared
                                         verbosity builddir
    buildArgs        = setupHsBuildArgs  pkg

1149
    replCommand      = Cabal.replCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
    replFlags _      = setupHsReplFlags pkg pkgshared
                                        verbosity builddir
    replArgs         = setupHsReplArgs  pkg

    haddockCommand   = Cabal.haddockCommand
    haddockFlags _   = setupHsHaddockFlags pkg pkgshared
                                           verbosity builddir

    scriptOptions    = setupHsScriptOptions rpkg pkgshared
                                            srcdir builddir
                                            isParallelBuild cacheLock

1162
1163
1164
1165
1166
1167
1168
1169
    setupInteractive :: CommandUI flags
                     -> (Version -> flags) -> [String] -> IO ()
    setupInteractive cmd flags args =
      setupWrapper verbosity
                   scriptOptions { isInteractive = True }
                   (Just (elabPkgDescription pkg))
                   cmd flags args

Duncan Coutts's avatar
Duncan Coutts committed
1170
1171
1172
1173
    setup :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()
    setup cmd flags args =
      setupWrapper verbosity
                   scriptOptions
1174
                   (Just (elabPkgDescription pkg))
Duncan Coutts's avatar
Duncan Coutts committed
1175
1176
                   cmd flags args

1177
1178
1179
    generateInstalledPackageInfo :: IO InstalledPackageInfo
    generateInstalledPackageInfo =
      withTempInstalledPackageInfoFile
1180
        verbosity distTempDirectory $ \pkgConfDest -> do
Duncan Coutts's avatar
Duncan Coutts committed
1181
1182
1183
        let registerFlags _ = setupHsRegisterFlags
                                pkg pkgshared
                                verbosity builddir
1184
                                pkgConfDest
Duncan Coutts's avatar
Duncan Coutts committed
1185
1186
        setup Cabal.registerCommand registerFlags []

1187
withTempInstalledPackageInfoFile :: Verbosity -> FilePath
1188
                                  -> (FilePath -> IO ())
1189
1190
                                  -> IO InstalledPackageInfo
withTempInstalledPackageInfoFile verbosity tempdir action =
1191
1192
1193
1194
1195
1196
1197
    withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do
      -- make absolute since @action@ will often change directory
      abs_dir <- canonicalizePath dir

      let pkgConfDest = abs_dir </> "pkgConf"
      action pkgConfDest

1198
      readPkgConf "." pkgConfDest
1199
1200
1201
1202
1203
1204
1205
1206
  where
    pkgConfParseFailed :: Installed.PError -> IO a
    pkgConfParseFailed perror =
      die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"
            ++ show perror

    readPkgConf pkgConfDir pkgConfFile = do
      (warns, ipkg) <- withUTF8FileContents (pkgConfDir </> pkgConfFile) $ \pkgConfStr ->