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

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
8
-- |
Duncan Coutts's avatar
Duncan Coutts committed
9
10
--
module Distribution.Client.ProjectBuilding (
11
    -- * Dry run phase
Duncan Coutts's avatar
Duncan Coutts committed
12
    BuildStatus(..),
13
    buildStatusToString,
Duncan Coutts's avatar
Duncan Coutts committed
14
15
16
17
18
    BuildStatusMap,
    BuildStatusRebuild(..),
    BuildReason(..),
    MonitorChangedReason(..),
    rebuildTargetsDryRun,
19
20

    -- * Build phase
21
22
23
    BuildOutcome,
    BuildOutcomes,
    BuildResult(..),
24
    BuildFailure(..),
25
    BuildFailureReason(..),
Duncan Coutts's avatar
Duncan Coutts committed
26
27
28
29
30
31
32
    rebuildTargets
  ) where

import           Distribution.Client.PackageHash (renderPackageHashInputs)
import           Distribution.Client.RebuildMonad
import           Distribution.Client.ProjectConfig
import           Distribution.Client.ProjectPlanning
33
import           Distribution.Client.ProjectPlanning.Types
Duncan Coutts's avatar
Duncan Coutts committed
34
35

import           Distribution.Client.Types
36
37
                   hiding (BuildOutcomes, BuildOutcome,
                           BuildResult(..), BuildFailure(..))
Duncan Coutts's avatar
Duncan Coutts committed
38
import           Distribution.Client.InstallPlan
39
                   ( GenericInstallPlan, GenericPlanPackage, IsUnit )
Duncan Coutts's avatar
Duncan Coutts committed
40
41
42
43
44
45
46
47
48
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)
49
import           Distribution.Client.SrcDist (allPackageSourceFiles)
Duncan Coutts's avatar
Duncan Coutts committed
50
51
52
53
54
55
56
57
58
59
60
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)
61
import qualified Distribution.Simple.Program.HcPkg as HcPkg
Duncan Coutts's avatar
Duncan Coutts committed
62
63
64
65
66
67

import           Distribution.Simple.Utils hiding (matchFileGlob)
import           Distribution.Version
import           Distribution.Verbosity
import           Distribution.Text
import           Distribution.ParseUtils ( showPWarning )
68
import           Distribution.Compat.Graph (IsNode(..))
Duncan Coutts's avatar
Duncan Coutts committed
69
70
71
72
73
74
75
76
77
78
79

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
80
import           Data.Typeable
Duncan Coutts's avatar
Duncan Coutts committed
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

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


------------------------------------------------------------------------------
-- * Overall building strategy.
------------------------------------------------------------------------------
--
-- We start with an 'ElaboratedInstallPlan' that has already been improved by
-- reusing packages from the store. So the remaining packages in the
-- '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.


------------------------------------------------------------------------------
-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?
------------------------------------------------------------------------------

-- We split things like this for a couple reasons. Firstly we need to be able
-- to do dry runs, and these need to be reasonably accurate in terms of
-- letting users know what (and why) things are going to be (re)built.
--
-- 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
-- (that would make it harder to reproduce the problem sitation).


123
124
125
-- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'.
--
-- This is used as the result of the dry-run of building an install plan.
Duncan Coutts's avatar
Duncan Coutts committed
126
--
127
type BuildStatusMap = Map UnitId BuildStatus
Duncan Coutts's avatar
Duncan Coutts committed
128

129
130
131
-- | The build status for an individual package is the state that the
-- package is in /prior/ to initiating a (re)build.
--
132
133
-- This should not be confused with a 'BuildResult' which is the result
-- /after/ successfully building a package.
Duncan Coutts's avatar
Duncan Coutts committed
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
--
-- It serves two purposes:
--
--  * For dry-run output, it lets us explain to the user if and why a package
--    is going to be (re)built.
--
--  * It tell us what step to start or resume building from, and carries
--    enough information for us to be able to do so.
--
data BuildStatus =

     -- | The package is in the 'InstallPlan.PreExisting' state, so does not
     --   need building.
     BuildStatusPreExisting

149
150
151
152
     -- | The package is in the 'InstallPlan.Installed' state, so does not
     --   need building.
   | BuildStatusInstalled

Duncan Coutts's avatar
Duncan Coutts committed
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
     -- | The package has not been downloaded yet, so it will have to be
     --   downloaded, unpacked and built.
   | BuildStatusDownload

     -- | The package has not been unpacked yet, so it will have to be
     --   unpacked and built.
   | BuildStatusUnpack FilePath

     -- | The package exists in a local dir already, and just needs building
     --   or rebuilding. So this can only happen for 'BuildInplaceOnly' style
     --   packages.
   | BuildStatusRebuild FilePath BuildStatusRebuild

     -- | The package exists in a local dir already, and is fully up to date.
     --   So this package can be put into the 'InstallPlan.Installed' state
     --   and it does not need to be built.
169
   | BuildStatusUpToDate BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
170

171
172
buildStatusToString :: BuildStatus -> String
buildStatusToString BuildStatusPreExisting      = "BuildStatusPreExisting"
173
buildStatusToString BuildStatusInstalled        = "BuildStatusInstalled"
174
175
176
177
178
buildStatusToString BuildStatusDownload         = "BuildStatusDownload"
buildStatusToString (BuildStatusUnpack fp)      = "BuildStatusUnpack " ++ show fp
buildStatusToString (BuildStatusRebuild fp _)   = "BuildStatusRebuild " ++ show fp
buildStatusToString (BuildStatusUpToDate _)     = "BuildStatusUpToDate"

Duncan Coutts's avatar
Duncan Coutts committed
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
-- | For a package that is going to be built or rebuilt, the state it's in now.
--
-- So again, this tells us why a package needs to be rebuilt and what build
-- phases need to be run. The 'MonitorChangedReason' gives us details like
-- which file changed, which is mainly for high verbosity debug output.
--
data BuildStatusRebuild =

     -- | The package configuration changed, so the configure and build phases
     --   needs to be (re)run.
     BuildStatusConfigure (MonitorChangedReason ())

     -- | The configuration has not changed but the build phase needs to be
     -- rerun. We record the reason the (re)build is needed.
     --
     -- The optional registration info here tells us if we've registered the
     -- package already, or if we stil need to do that after building.
196
197
     -- @Just Nothing@ indicates that we know that no registration is
     -- necessary (e.g., executable.)
Duncan Coutts's avatar
Duncan Coutts committed
198
     --
199
   | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason
Duncan Coutts's avatar
Duncan Coutts committed
200
201

data BuildReason =
202
     -- | The dependencies of this package have been (re)built so the build
Duncan Coutts's avatar
Duncan Coutts committed
203
204
205
206
207
208
209
     -- phase needs to be rerun.
     --
     -- The optional registration info here tells us if we've registered the
     -- package already, or if we stil need to do that after building.
     --
     BuildReasonDepsRebuilt

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
210
     -- | Changes in files within the package (or first run or corrupt cache)
Duncan Coutts's avatar
Duncan Coutts committed
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
   | BuildReasonFilesChanged (MonitorChangedReason ())

     -- | An important special case is that no files have changed but the
     -- set of components the /user asked to build/ has changed. We track the
     -- set of components /we have built/, which of course only grows (until
     -- some other change resets it).
     --
     -- The @Set 'ComponentName'@ is the set of components we have built
     -- previously. When we update the monitor we take the union of the ones
     -- we have built previously with the ones the user has asked for this
     -- time and save those. See 'updatePackageBuildFileMonitor'.
     --
   | BuildReasonExtraTargets (Set ComponentName)

     -- | Although we're not going to build any additional targets as a whole,
     -- we're going to build some part of a component or run a repl or any
     -- other action that does not result in additional persistent artifacts.
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
228
     --
Duncan Coutts's avatar
Duncan Coutts committed
229
230
231
232
233
234
235
236
   | BuildReasonEphemeralTargets

-- | Which 'BuildStatus' values indicate we'll have to do some build work of
-- some sort. In particular we use this as part of checking if any of a
-- package's deps have changed.
--
buildStatusRequiresBuild :: BuildStatus -> Bool
buildStatusRequiresBuild BuildStatusPreExisting = False
237
buildStatusRequiresBuild BuildStatusInstalled   = False
Duncan Coutts's avatar
Duncan Coutts committed
238
239
240
241
242
243
244
245
246
buildStatusRequiresBuild BuildStatusUpToDate {} = False
buildStatusRequiresBuild _                      = True

-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.
--
-- It gives us the 'BuildStatusMap' and also gives us an improved version of
-- the 'ElaboratedInstallPlan' with packages switched to the
-- 'InstallPlan.Installed' state when we find that they're already up to date.
--
247
248
249
rebuildTargetsDryRun :: Verbosity
                     -> DistDirLayout
                     -> ElaboratedSharedConfig
Duncan Coutts's avatar
Duncan Coutts committed
250
251
                     -> ElaboratedInstallPlan
                     -> IO (ElaboratedInstallPlan, BuildStatusMap)
252
rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \installPlan -> do
Duncan Coutts's avatar
Duncan Coutts committed
253
254
255
256
257
258
259
260

    -- Do the various checks to work out the 'BuildStatus' of each package
    pkgsBuildStatus <- foldMInstallPlanDepOrder installPlan dryRunPkg

    -- For 'BuildStatusUpToDate' packages, improve the plan by marking them as
    -- 'InstallPlan.Installed'.
    let installPlan' = improveInstallPlanWithUpToDatePackages
                         installPlan pkgsBuildStatus
261
    debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan'
Duncan Coutts's avatar
Duncan Coutts committed
262
263
264
265

    return (installPlan', pkgsBuildStatus)
  where
    dryRunPkg :: ElaboratedPlanPackage
266
              -> [BuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
267
268
269
270
              -> IO BuildStatus
    dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
      return BuildStatusPreExisting

271
    dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =
272
      return BuildStatusInstalled
273

Duncan Coutts's avatar
Duncan Coutts committed
274
    dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
275
      mloc <- checkFetched (elabPkgSourceLocation pkg)
Duncan Coutts's avatar
Duncan Coutts committed
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
      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
297
                     -> [BuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
298
299
300
                     -> FilePath
                     -> IO BuildStatus
    dryRunTarballPkg pkg depsBuildStatus tarball =
301
      case elabBuildStyle pkg of
Duncan Coutts's avatar
Duncan Coutts committed
302
303
304
305
306
307
308
309
310
311
312
        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
313
                   -> [BuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
314
315
316
317
318
319
320
321
322
323
324
325
326
                   -> 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.
327
328
          Right buildResult ->
            return (BuildStatusUpToDate buildResult)
Duncan Coutts's avatar
Duncan Coutts committed
329
330
      where
        packageFileMonitor =
331
          newPackageFileMonitor distDirLayout (elabDistDirParams shared pkg)
Duncan Coutts's avatar
Duncan Coutts committed
332
333
334
335
336


-- | A specialised traversal over the packages in an install plan.
--
-- The packages are visited in dependency order, starting with packages with no
337
-- dependencies. The result for each package is accumulated into a 'Map' and
Duncan Coutts's avatar
Duncan Coutts committed
338
339
-- returned as the final result. In addition, when visting a package, the
-- visiting function is passed the results for all the immediate package
340
-- dependencies. This can be used to propagate information from dependencies.
Duncan Coutts's avatar
Duncan Coutts committed
341
342
--
foldMInstallPlanDepOrder
343
  :: forall m ipkg srcpkg b.
344
     (Monad m, IsUnit ipkg, IsUnit srcpkg)
345
346
  => GenericInstallPlan ipkg srcpkg
  -> (GenericPlanPackage ipkg srcpkg ->
347
      [b] -> m b)
348
  -> m (Map UnitId b)
Duncan Coutts's avatar
Duncan Coutts committed
349
350
351
foldMInstallPlanDepOrder plan0 visit =
    go Map.empty (InstallPlan.reverseTopologicalOrder plan0)
  where
352
    go :: Map UnitId b
353
       -> [GenericPlanPackage ipkg srcpkg]
354
       -> m (Map UnitId b)
Duncan Coutts's avatar
Duncan Coutts committed
355
356
357
358
    go !results [] = return results

    go !results (pkg : pkgs) = do
      -- we go in the right order so the results map has entries for all deps
359
      let depresults :: [b]
Duncan Coutts's avatar
Duncan Coutts committed
360
          depresults =
361
362
            map (\ipkgid -> let Just result = Map.lookup ipkgid results
                              in result)
363
                (InstallPlan.depends pkg)
Duncan Coutts's avatar
Duncan Coutts committed
364
      result <- visit pkg depresults
365
      let results' = Map.insert (nodeKey pkg) result results
Duncan Coutts's avatar
Duncan Coutts committed
366
367
368
369
370
371
      go results' pkgs

improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan
                                       -> BuildStatusMap
                                       -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
372
373
    replaceWithInstalled installPlan
      [ installedUnitId pkg
Duncan Coutts's avatar
Duncan Coutts committed
374
375
      | InstallPlan.Configured pkg
          <- InstallPlan.reverseTopologicalOrder installPlan
376
377
378
379
      , case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
          Just BuildStatusUpToDate {} -> True
          Just _                      -> False
          Nothing -> error "improveInstallPlanWithUpToDatePackages: impossible"
Duncan Coutts's avatar
Duncan Coutts committed
380
381
      ]
  where
382
383
384
385
    replaceWithInstalled :: ElaboratedInstallPlan -> [UnitId]
                         -> ElaboratedInstallPlan
    replaceWithInstalled =
      foldl' (flip InstallPlan.installed)
Duncan Coutts's avatar
Duncan Coutts committed
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403


-----------------------------
-- 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 (),
404
       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildResultMisc,
405
       pkgFileMonitorReg    :: FileMonitor () (Maybe InstalledPackageInfo)
Duncan Coutts's avatar
Duncan Coutts committed
406
407
     }

408
-- | This is all the components of the 'BuildResult' other than the
409
410
-- @['InstalledPackageInfo']@.
--
411
-- We have to split up the 'BuildResult' components since they get produced
412
413
-- at different times (or rather, when different things change).
--
414
type BuildResultMisc = (DocsResult, TestsResult)
415

416
417
newPackageFileMonitor :: DistDirLayout -> DistDirParams -> PackageFileMonitor
newPackageFileMonitor DistDirLayout{distPackageCacheFile} dparams =
Duncan Coutts's avatar
Duncan Coutts committed
418
419
    PackageFileMonitor {
      pkgFileMonitorConfig =
420
        newFileMonitor (distPackageCacheFile dparams "config"),
Duncan Coutts's avatar
Duncan Coutts committed
421
422
423

      pkgFileMonitorBuild =
        FileMonitor {
424
          fileMonitorCacheFile = distPackageCacheFile dparams "build",
Duncan Coutts's avatar
Duncan Coutts committed
425
426
427
428
429
430
          fileMonitorKeyValid  = \componentsToBuild componentsAlreadyBuilt ->
            componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,
          fileMonitorCheckIfOnlyValueChanged = True
        },

      pkgFileMonitorReg =
431
        newFileMonitor (distPackageCacheFile dparams "registration")
Duncan Coutts's avatar
Duncan Coutts committed
432
433
434
435
436
437
438
439
440
441
    }

-- | 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)
442
443
packageFileMonitorKeyValues elab =
    (elab_config, buildComponents)
Duncan Coutts's avatar
Duncan Coutts committed
444
445
446
447
448
449
450
451
  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.
    --
452
453
454
455
456
457
    elab_config =
        elab {
            elabBuildTargets = [],
            elabReplTarget    = Nothing,
            elabBuildHaddocks = False
        }
Duncan Coutts's avatar
Duncan Coutts committed
458
459
460
461
462

    -- 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.
    --
463
    buildComponents = elabBuildTargetWholeComponents elab
Duncan Coutts's avatar
Duncan Coutts committed
464
465
466
467
468
469
470

-- | Do all the checks on whether a package has changed and thus needs either
-- rebuilding or reconfiguring and rebuilding.
--
checkPackageFileMonitorChanged :: PackageFileMonitor
                               -> ElaboratedConfiguredPackage
                               -> FilePath
471
                               -> [BuildStatus]
472
                               -> IO (Either BuildStatusRebuild BuildResult)
Duncan Coutts's avatar
Duncan Coutts committed
473
474
475
476
477
478
479
480
481
482
483
484
485
486
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
487
          -- of dependencies.
488
        | any buildStatusRequiresBuild depsBuildStatus -> do
Duncan Coutts's avatar
Duncan Coutts committed
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
            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

526
              (MonitorUnchanged buildResult _, MonitorUnchanged mipkg _) ->
527
528
529
                  return $ Right BuildResult {
                    buildResultDocs    = docsResult,
                    buildResultTests   = testsResult,
530
                    buildResultLogFile = Nothing,
531
                    buildResultLibInfo = mipkg
532
                  }
533
                where
534
                  (docsResult, testsResult) = buildResult
Duncan Coutts's avatar
Duncan Coutts committed
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
  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]
558
                              -> BuildResultMisc
Duncan Coutts's avatar
Duncan Coutts committed
559
560
561
                              -> IO ()
updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}
                              srcdir timestamp pkg pkgBuildStatus
562
                              allSrcFiles buildResult =
Duncan Coutts's avatar
Duncan Coutts committed
563
    updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)
564
                      (map monitorFileHashed allSrcFiles)
565
                      buildComponents' buildResult
Duncan Coutts's avatar
Duncan Coutts committed
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
  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
584
                            -> Maybe InstalledPackageInfo
Duncan Coutts's avatar
Duncan Coutts committed
585
586
                            -> IO ()
updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg}
587
                            srcdir mipkg =
Duncan Coutts's avatar
Duncan Coutts committed
588
    updateFileMonitor pkgFileMonitorReg srcdir Nothing
589
                      [] () mipkg
Duncan Coutts's avatar
Duncan Coutts committed
590
591
592
593
594
595
596
597
598
599

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


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

600
601
602
603
604
605
606
607
608
609
610
611
612
613
-- | A summary of the outcome for building a whole set of packages.
--
type BuildOutcomes = Map UnitId BuildOutcome

-- | A summary of the outcome for building a single package: either success
-- or failure.
--
type BuildOutcome  = Either BuildFailure BuildResult

-- | Information arising from successfully building a single package.
--
data BuildResult = BuildResult {
       buildResultDocs    :: DocsResult,
       buildResultTests   :: TestsResult,
614
       buildResultLogFile :: Maybe FilePath,
615
616
617
618
619
620
621
622
623
       -- | If the build was for a library, this field will be @Just@;
       -- otherwise, it will be @Nothing@.  What about internal
       -- libraries?  This never occurs, because a build result is either
       -- for a per-component build (in which case there won't
       -- be multiple libraries), or a package with no internal
       -- libraries (internal libraries with Custom setups are NOT
       -- supported, and even if they were supported, we could
       -- assume the Cabal library version was recent enough to
       -- support per-component build.).
624
       buildResultLibInfo :: Maybe InstalledPackageInfo
625
626
627
628
629
     }
  deriving Show

-- | Information arising from the failure to build a single package.
--
630
631
632
633
data BuildFailure = BuildFailure {
       buildFailureLogFile :: Maybe FilePath,
       buildFailureReason  :: BuildFailureReason
     }
634
635
636
  deriving (Show, Typeable)

instance Exception BuildFailure
Duncan Coutts's avatar
Duncan Coutts committed
637

638
639
-- | Detail on the reason that a package failed to build.
--
640
data BuildFailureReason = DependentFailed PackageId
641
642
643
644
                        | DownloadFailed  SomeException
                        | UnpackFailed    SomeException
                        | ConfigureFailed SomeException
                        | BuildFailed     SomeException
645
646
                        | ReplFailed      SomeException
                        | HaddocksFailed  SomeException
647
648
649
650
                        | TestsFailed     SomeException
                        | InstallFailed   SomeException
  deriving Show

Duncan Coutts's avatar
Duncan Coutts committed
651
652
-- | Build things for real.
--
Edward Z. Yang's avatar
Edward Z. Yang committed
653
-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.
Duncan Coutts's avatar
Duncan Coutts committed
654
655
656
657
658
659
660
--
rebuildTargets :: Verbosity
               -> DistDirLayout
               -> ElaboratedInstallPlan
               -> ElaboratedSharedConfig
               -> BuildStatusMap
               -> BuildTimeSettings
661
               -> IO BuildOutcomes
Duncan Coutts's avatar
Duncan Coutts committed
662
663
664
rebuildTargets verbosity
               distDirLayout@DistDirLayout{..}
               installPlan
665
666
667
668
               sharedPackageConfig@ElaboratedSharedConfig {
                 pkgConfigCompiler      = compiler,
                 pkgConfigCompilerProgs = progdb
               }
Duncan Coutts's avatar
Duncan Coutts committed
669
               pkgsBuildStatus
670
671
672
673
               buildSettings@BuildTimeSettings{
                 buildSettingNumJobs,
                 buildSettingKeepGoing
               } = do
Duncan Coutts's avatar
Duncan Coutts committed
674
675
676

    -- Concurrency control: create the job controller and concurrency limits
    -- for downloading, building and installing.
677
678
679
    jobControl    <- if isParallelBuild
                       then newParallelJobControl buildSettingNumJobs
                       else newSerialJobControl
680
    registerLock  <- newLock -- serialise registration
Duncan Coutts's avatar
Duncan Coutts committed
681
682
683
    cacheLock     <- newLock -- serialise access to setup exe cache
                             --TODO: [code cleanup] eliminate setup exe cache

684
685
    createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
    createDirectoryIfMissingVerbose verbosity True distTempDirectory
686
    mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
Duncan Coutts's avatar
Duncan Coutts committed
687
688
689
690
691
692
693

    -- 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...
694
695
      InstallPlan.execute jobControl keepGoing
                          (BuildFailure Nothing . DependentFailed . packageId)
696
                          installPlan $ \pkg ->
697
698
        --TODO: review exception handling
        handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $
Duncan Coutts's avatar
Duncan Coutts committed
699

700
701
        let uid = installedUnitId pkg
            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in
Duncan Coutts's avatar
Duncan Coutts committed
702
703
704
705
706

        rebuildTarget
          verbosity
          distDirLayout
          buildSettings downloadMap
707
          registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
708
709
710
711
712
          sharedPackageConfig
          pkg
          pkgBuildStatus
  where
    isParallelBuild = buildSettingNumJobs >= 2
713
    keepGoing       = buildSettingKeepGoing
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
714
    withRepoCtx     = projectConfigWithBuilderRepoContext verbosity
Duncan Coutts's avatar
Duncan Coutts committed
715
                        buildSettings
716
717
718
    packageDBsToUse = -- all the package dbs we may need to create
      (Set.toList . Set.fromList)
        [ pkgdb
719
720
721
722
        | InstallPlan.Configured elab <- InstallPlan.toList installPlan
        , (pkgdb:_) <- map reverse [ elabBuildPackageDBStack elab,
                                     elabRegisterPackageDBStack elab,
                                     elabSetupPackageDBStack elab ]
723
        ]
Duncan Coutts's avatar
Duncan Coutts committed
724
725
726
727
728
729

-- | Given all the context and resources, (re)build an individual package.
--
rebuildTarget :: Verbosity
              -> DistDirLayout
              -> BuildTimeSettings
Duncan Coutts's avatar
Duncan Coutts committed
730
              -> AsyncFetchMap
731
              -> Lock -> Lock
Duncan Coutts's avatar
Duncan Coutts committed
732
733
734
              -> ElaboratedSharedConfig
              -> ElaboratedReadyPackage
              -> BuildStatus
735
              -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
736
737
738
rebuildTarget verbosity
              distDirLayout@DistDirLayout{distBuildDirectory}
              buildSettings downloadMap
739
              registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
740
              sharedPackageConfig
741
              rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
742
743
744
745
746
747
748
749
750
751
              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
752
      BuildStatusInstalled   {} -> unexpectedState
Duncan Coutts's avatar
Duncan Coutts committed
753
754
755
756
757
      BuildStatusUpToDate    {} -> unexpectedState
  where
    unexpectedState = error "rebuildTarget: unexpected package status"

    downloadPhase = do
758
        downsrcloc <- annotateFailureNoLog DownloadFailed $
759
                        waitAsyncPackageDownload verbosity downloadMap pkg
Duncan Coutts's avatar
Duncan Coutts committed
760
761
762
763
764
765
766
767
        case downsrcloc of
          DownloadedTarball tarball -> unpackTarballPhase tarball
          --TODO: [nice to have] git/darcs repos etc


    unpackTarballPhase tarball =
        withTarballLocalDirectory
          verbosity distDirLayout tarball
768
769
          (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg)
          (elabPkgDescriptionOverride pkg) $
Duncan Coutts's avatar
Duncan Coutts committed
770

771
          case elabBuildStyle pkg of
Duncan Coutts's avatar
Duncan Coutts committed
772
773
774
775
776
777
778
779
780
781
            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 =
782
        assert (elabBuildStyle pkg == BuildInplaceOnly) $
Duncan Coutts's avatar
Duncan Coutts committed
783
784
785

          buildInplace buildStatus srcdir builddir
      where
786
        builddir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg)
Duncan Coutts's avatar
Duncan Coutts committed
787
788
789
790

    buildAndInstall srcdir builddir =
        buildAndInstallUnpackedPackage
          verbosity distDirLayout
791
          buildSettings registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
792
793
794
795
796
797
798
799
800
801
802
          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
803
          buildSettings registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
          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
822
                      -> ((RepoContext -> IO a) -> IO a)
Duncan Coutts's avatar
Duncan Coutts committed
823
824
                      -> ElaboratedInstallPlan
                      -> BuildStatusMap
Duncan Coutts's avatar
Duncan Coutts committed
825
                      -> (AsyncFetchMap -> IO a)
Duncan Coutts's avatar
Duncan Coutts committed
826
827
828
                      -> IO a
asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
  | null pkgsToDownload = body Map.empty
Duncan Coutts's avatar
Duncan Coutts committed
829
830
831
  | otherwise           = withRepoCtx $ \repoctx ->
                            asyncFetchPackages verbosity repoctx
                                               pkgsToDownload body
Duncan Coutts's avatar
Duncan Coutts committed
832
  where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
833
    pkgsToDownload =
834
      ordNub $
835
836
      [ elabPkgSourceLocation elab
      | InstallPlan.Configured elab
Duncan Coutts's avatar
Duncan Coutts committed
837
         <- InstallPlan.reverseTopologicalOrder installPlan
838
      , let uid = installedUnitId elab
839
            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus
Duncan Coutts's avatar
Duncan Coutts committed
840
841
842
843
844
      , BuildStatusDownload <- [pkgBuildStatus]
      ]


-- | Check if a package needs downloading, and if so expect to find a download
Duncan Coutts's avatar
Duncan Coutts committed
845
-- in progress in the given 'AsyncFetchMap' and wait on it to finish.
Duncan Coutts's avatar
Duncan Coutts committed
846
847
--
waitAsyncPackageDownload :: Verbosity
Duncan Coutts's avatar
Duncan Coutts committed
848
                         -> AsyncFetchMap
Duncan Coutts's avatar
Duncan Coutts committed
849
850
                         -> ElaboratedConfiguredPackage
                         -> IO DownloadedSourceLocation
851
waitAsyncPackageDownload verbosity downloadMap elab = do
Duncan Coutts's avatar
Duncan Coutts committed
852
    pkgloc <- waitAsyncFetchPackage verbosity downloadMap
853
                                    (elabPkgSourceLocation elab)
Duncan Coutts's avatar
Duncan Coutts committed
854
855
856
857
858
859
860
861
862
863
864
865
866
867
    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
868
869
870
871
872




-- | Ensure that the package is unpacked in an appropriate directory, either
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
873
-- a temporary one or a persistent one under the shared dist directory.
Duncan Coutts's avatar
Duncan Coutts committed
874
875
876
877
878
879
--
withTarballLocalDirectory
  :: Verbosity
  -> DistDirLayout
  -> FilePath
  -> PackageId
880
  -> DistDirParams
Duncan Coutts's avatar
Duncan Coutts committed
881
882
  -> BuildStyle
  -> Maybe CabalFileText
883
884
885
  -> (FilePath -> -- Source directory
      FilePath -> -- Build directory
      IO a)
Duncan Coutts's avatar
Duncan Coutts committed
886
887
  -> IO a
withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}
888
                          tarball pkgid dparams buildstyle pkgTextOverride
Duncan Coutts's avatar
Duncan Coutts committed
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
                          buildPkg  =
      case buildstyle of
        -- In this case we make a temp dir, unpack the tarball to there and
        -- build and install it from that temp dir.
        BuildAndInstall ->
          withTempDirectory verbosity distTempDirectory
                            (display (packageName pkgid)) $ \tmpdir -> do
            unpackPackageTarball verbosity tarball tmpdir
                                 pkgid pkgTextOverride
            let srcdir   = tmpdir </> display pkgid
                builddir = srcdir </> "dist"
            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
908
              builddir   = distBuildDirectory dparams
Duncan Coutts's avatar
Duncan Coutts committed
909
910
911
          -- TODO: [nice to have] use a proper file monitor rather than this dir exists test
          exists <- doesDirectoryExist srcdir
          unless exists $ do
912
            createDirectoryIfMissingVerbose verbosity True srcrootdir
Duncan Coutts's avatar
Duncan Coutts committed
913
914
915
            unpackPackageTarball verbosity tarball srcrootdir
                                 pkgid pkgTextOverride
            moveTarballShippedDistDirectory verbosity distDirLayout
916
                                            srcrootdir pkgid dparams
Duncan Coutts's avatar
Duncan Coutts committed
917
918
919
920
921
922
923
924
          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
925
    annotateFailureNoLog UnpackFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961

      -- 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
962
                                -> FilePath -> PackageId -> DistDirParams -> IO ()
Duncan Coutts's avatar
Duncan Coutts committed
963
moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
964
                                parentdir pkgid dparams = do
Duncan Coutts's avatar
Duncan Coutts committed
965
966
967
968
969
970
971
972
    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"
973
    targetDistDir  = distBuildDirectory dparams
Duncan Coutts's avatar
Duncan Coutts committed
974
975
976
977
978
979
980
981


buildAndInstallUnpackedPackage :: Verbosity
                               -> DistDirLayout
                               -> BuildTimeSettings -> Lock -> Lock
                               -> ElaboratedSharedConfig
                               -> ElaboratedReadyPackage
                               -> FilePath -> FilePath
982
                               -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
983
984
985
986
987
988
buildAndInstallUnpackedPackage verbosity
                               DistDirLayout{distTempDirectory}
                               BuildTimeSettings {
                                 buildSettingNumJobs,
                                 buildSettingLogFile
                               }
989
                               registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
990
                               pkgshared@ElaboratedSharedConfig {
991
992
993
                                 pkgConfigPlatform      = platform,
                                 pkgConfigCompiler      = compiler,
                                 pkgConfigCompilerProgs = progdb
Duncan Coutts's avatar
Duncan Coutts committed
994
                               }
995
                               rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
996
997
                               srcdir builddir = do

998
    createDirectoryIfMissingVerbose verbosity True builddir
Duncan Coutts's avatar
Duncan Coutts committed
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
    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

1011
    let dispname = case elabPkgOrComp pkg of
1012
1013
            ElabPackage _ -> display pkgid
            ElabComponent comp -> display pkgid ++ " "
1014
                ++ maybe "custom" display (compComponentName comp)
1015

Duncan Coutts's avatar
Duncan Coutts committed
1016
1017
    -- Configure phase
    when isParallelBuild $
1018
      notice verbosity $ "Configuring " ++ dispname ++ "..."
1019
    annotateFailure mlogFile ConfigureFailed $
1020
      setup' configureCommand configureFlags configureArgs
Duncan Coutts's avatar
Duncan Coutts committed
1021
1022
1023

    -- Build phase
    when isParallelBuild $
1024
      notice verbosity $ "Building " ++ dispname ++ "..."
1025
    annotateFailure mlogFile BuildFailed $
Duncan Coutts's avatar
Duncan Coutts committed
1026
1027
1028
      setup buildCommand buildFlags

    -- Install phase
1029
    mipkg <-
1030
      annotateFailure mlogFile InstallFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
1031
1032
1033
1034
1035
1036
1037
1038
1039
      --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
1040

Duncan Coutts's avatar
Duncan Coutts committed
1041
      LBS.writeFile
1042
        (InstallDirs.prefix (elabInstallDirs pkg) </> "cabal-hash.txt") $
Duncan Coutts's avatar
Duncan Coutts committed
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
        (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.

1053
      if elabRequiresRegistration pkg
Duncan Coutts's avatar
Duncan Coutts committed
1054
1055
1056
1057
        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.
1058
          ipkg0 <- generateInstalledPackageInfo
1059
          let ipkg = ipkg0 { Installed.installedUnitId = uid }
1060

1061
          criticalSection registerLock $
1062
1063
              Cabal.registerPackage verbosity compiler progdb
                                    HcPkg.MultiInstance
1064
                                    (elabRegisterPackageDBStack pkg) ipkg
1065
1066
          return (Just ipkg)
        else return Nothing
Duncan Coutts's avatar
Duncan Coutts committed
1067
1068
1069
1070
1071

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

1072
1073
1074
    return BuildResult {
       buildResultDocs    = docsResult,
       buildResultTests   = testsResult,
1075
       buildResultLogFile = mlogFile,
1076
       buildResultLibInfo = mipkg
1077
    }
Duncan Coutts's avatar
Duncan Coutts committed
1078
1079
1080

  where
    pkgid  = packageId rpkg
1081
    uid = installedUnitId rpkg
Duncan Coutts's avatar
Duncan Coutts committed
1082
1083
1084

    isParallelBuild = buildSettingNumJobs >= 2

1085
    configureCommand = Cabal.configureCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
1086
1087
1088
    configureFlags v = flip filterConfigureFlags v $
                       setupHsConfigureFlags rpkg pkgshared
                                             verbosity builddir
1089
    configureArgs    = setupHsConfigureArgs pkg
Duncan Coutts's avatar
Duncan Coutts committed
1090

1091
    buildCommand     = Cabal.buildCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
1092
1093
    buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir

1094
1095
1096
    generateInstalledPackageInfo :: IO InstalledPackageInfo
    generateInstalledPackageInfo =
      withTempInstalledPackageInfoFile
1097
        verbosity distTempDirectory $ \pkgConfDest -> do
Duncan Coutts's avatar
Duncan Coutts committed
1098
1099
1100
        let registerFlags _ = setupHsRegisterFlags
                                pkg pkgshared
                                verbosity builddir
1101
                                pkgConfDest
Duncan Coutts's avatar
Duncan Coutts committed
1102
1103
1104
1105
1106
1107
1108
1109
        setup Cabal.registerCommand registerFlags

    copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir

    scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir
                                         isParallelBuild cacheLock

    setup :: CommandUI flags -> (Version -> flags) -> IO ()
1110
1111
1112
1113
    setup cmd flags = setup' cmd flags []

    setup' :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()
    setup' cmd flags args =
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
1114
      withLogging $ \mLogFileHandle ->
Duncan Coutts's avatar
Duncan Coutts committed
1115
1116
1117
        setupWrapper
          verbosity
          scriptOptions { useLoggingHandle = mLogFileHandle }
1118
          (Just (elabPkgDescription pkg))
1119
          cmd flags args
Duncan Coutts's avatar
Duncan Coutts committed
1120

1121
    mlogFile :: Maybe FilePath
Duncan Coutts's avatar
Duncan Coutts committed
1122
1123
1124
    mlogFile =
      case buildSettingLogFile of
        Nothing        -> Nothing
1125
        Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
Duncan Coutts's avatar
Duncan Coutts committed
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142

    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
1143
                            -> BuildTimeSettings -> Lock -> Lock
Duncan Coutts's avatar
Duncan Coutts committed
1144
1145
1146
1147
                            -> ElaboratedSharedConfig
                            -> ElaboratedReadyPackage
                            -> BuildStatusRebuild
                            -> FilePath -> FilePath
1148
                            -> IO BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
1149
1150
1151
1152
1153
1154
buildInplaceUnpackedPackage verbosity
                            distDirLayout@DistDirLayout {
                              distTempDirectory,
                              distPackageCacheDirectory
                            }
                            BuildTimeSettings{buildSettingNumJobs}
1155
                            registerLock cacheLock
Duncan Coutts's avatar
Duncan Coutts committed
1156
                            pkgshared@ElaboratedSharedConfig {
1157
1158
                              pkgConfigCompiler      = compiler,
                              pkgConfigCompilerProgs = progdb
Duncan Coutts's avatar
Duncan Coutts committed
1159
                            }
1160
                            rpkg@(ReadyPackage pkg)
Duncan Coutts's avatar
Duncan Coutts committed
1161
1162
1163
1164
1165
                            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
1166
1167
        createDirectoryIfMissingVerbose verbosity True builddir
        createDirectoryIfMissingVerbose verbosity True (distPackageCacheDirectory dparams)
Duncan Coutts's avatar
Duncan Coutts committed
1168
1169
1170
1171

        -- Configure phase
        --
        whenReConfigure $ do
1172
          annotateFailureNoLog ConfigureFailed $
1173
            setup configureCommand configureFlags configureArgs
Duncan Coutts's avatar
Duncan Coutts committed
1174
1175
1176
1177
1178
1179
1180
1181
          invalidatePackageRegFileMonitor packageFileMonitor
          updatePackageConfigFileMonitor packageFileMonitor srcdir pkg

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

1182
1183
            buildResult :: BuildResultMisc
            buildResult = (docsResult, testsResult)
Duncan Coutts's avatar
Duncan Coutts committed
1184
1185
1186

        whenRebuild $ do
          timestamp <- beginUpdateFileMonitor
1187
          annotateFailureNoLog BuildFailed $
1188
            setup buildCommand buildFlags buildArgs
Duncan Coutts's avatar
Duncan Coutts committed
1189

1190
1191
1192
          --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.
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
          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
            in if elabSetupScriptCliVersion pkg >= Version [1,17] []
                  then do r <- trySdist
                          if null r
                            then tryFallback
                            else return r
                  else tryFallback
Duncan Coutts's avatar
Duncan Coutts committed
1209
1210
1211

          updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp
                                        pkg buildStatus
1212
                                        allSrcFiles buildResult
Duncan Coutts's avatar
Duncan Coutts committed
1213

1214
1215
        -- PURPOSELY omitted: no copy!

1216
        mipkg <- whenReRegister $
1217
                 annotateFailureNoLog InstallFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
1218
          -- Register locally
1219
          mipkg <- if elabRequiresRegistration pkg
Duncan Coutts's avatar
Duncan Coutts committed
1220
            then do
1221
                ipkg0 <- generateInstalledPackageInfo
Duncan Coutts's avatar
Duncan Coutts committed
1222
1223
1224
                -- 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.
1225
                let ipkg = ipkg0 { Installed.installedUnitId = ipkgid }
1226
                criticalSection registerLock $
1227
                    Cabal.registerPackage verbosity compiler progdb HcPkg.NoMultiInstance
1228
                                          (elabRegisterPackageDBStack pkg)
1229
1230
                                          ipkg
                return (Just ipkg)
1231

1232
           else return Nothing
1233

1234
1235
          updatePackageRegFileMonitor packageFileMonitor srcdir mipkg
          return mipkg
Duncan Coutts's avatar
Duncan Coutts committed
1236
1237
1238
1239

        -- Repl phase
        --
        whenRepl $
1240
          annotateFailureNoLog ReplFailed $
Duncan Coutts's avatar
Duncan Coutts committed
1241
1242
1243
1244
          setup replCommand replFlags replArgs

        -- Haddock phase
        whenHaddock $
1245
          annotateFailureNoLog HaddocksFailed $
Duncan Coutts's avatar
Duncan Coutts committed
1246
1247
          setup haddockCommand haddockFlags []

1248
1249
1250
        return BuildResult {
          buildResultDocs    = docsResult,
          buildResultTests   = testsResult,
1251
          buildResultLogFile = Nothing,
1252
          buildResultLibInfo = mipkg
1253
        }
Duncan Coutts's avatar
Duncan Coutts committed
1254
1255

  where
1256
1257
    ipkgid  = installedUnitId pkg
    dparams = elabDistDirParams pkgshared pkg
Duncan Coutts's avatar
Duncan Coutts committed
1258
1259
1260

    isParallelBuild = buildSettingNumJobs >= 2

1261
    packageFileMonitor = newPackageFileMonitor distDirLayout dparams
Duncan Coutts's avatar
Duncan Coutts committed
1262
1263
1264
1265
1266
1267

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

    whenRebuild action
1268
      | null (elabBuildTargets pkg) = return ()
Duncan Coutts's avatar
Duncan Coutts committed
1269
1270
1271
      | otherwise                  = action

    whenRepl action
1272
      | isNothing (elabReplTarget pkg) = return ()
Duncan Coutts's avatar
Duncan Coutts committed
1273
1274
1275
      | otherwise                     = action

    whenHaddock action
1276
      | elabBuildHaddocks pkg = action
Duncan Coutts's avatar
Duncan Coutts committed
1277
1278
1279
1280
1281
      | otherwise            = return ()

    whenReRegister  action = case buildStatus of
      BuildStatusConfigure          _ -> action
      BuildStatusBuild Nothing      _ -> action