ProjectBuilding.hs 56.3 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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
--
-- 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

     -- | 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.
165
   | BuildStatusUpToDate BuildResult
Duncan Coutts's avatar
Duncan Coutts committed
166

167
168
169
170
171
172
173
buildStatusToString :: BuildStatus -> String
buildStatusToString BuildStatusPreExisting      = "BuildStatusPreExisting"
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
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
-- | 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.
191
192
     -- @Just Nothing@ indicates that we know that no registration is
     -- necessary (e.g., executable.)
Duncan Coutts's avatar
Duncan Coutts committed
193
     --
194
   | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason
Duncan Coutts's avatar
Duncan Coutts committed
195
196
197
198
199
200
201
202
203
204

data BuildReason =
     -- | The depencencies of this package have been (re)built so the build
     -- 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
205
     -- | Changes in files within the package (or first run or corrupt cache)
Duncan Coutts's avatar
Duncan Coutts committed
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
   | 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
223
     --
Duncan Coutts's avatar
Duncan Coutts committed
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
   | 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
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.
--
241
242
243
rebuildTargetsDryRun :: Verbosity
                     -> DistDirLayout
                     -> ElaboratedSharedConfig
Duncan Coutts's avatar
Duncan Coutts committed
244
245
                     -> ElaboratedInstallPlan
                     -> IO (ElaboratedInstallPlan, BuildStatusMap)
246
rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \installPlan -> do
Duncan Coutts's avatar
Duncan Coutts committed
247
248
249
250
251
252
253
254

    -- 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
255
    debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan'
Duncan Coutts's avatar
Duncan Coutts committed
256
257
258
259

    return (installPlan', pkgsBuildStatus)
  where
    dryRunPkg :: ElaboratedPlanPackage
260
              -> [BuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
261
262
263
264
265
              -> IO BuildStatus
    dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
      return BuildStatusPreExisting

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


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

    go !results (pkg : pkgs) = do
      -- we go in the right order so the results map has entries for all deps
350
      let depresults :: [b]
Duncan Coutts's avatar
Duncan Coutts committed
351
          depresults =
352
353
            map (\ipkgid -> let Just result = Map.lookup ipkgid results
                              in result)
354
                (InstallPlan.depends pkg)
Duncan Coutts's avatar
Duncan Coutts committed
355
      result <- visit pkg depresults
356
      let results' = Map.insert (nodeKey pkg) result results
Duncan Coutts's avatar
Duncan Coutts committed
357
358
359
360
361
362
      go results' pkgs

improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan
                                       -> BuildStatusMap
                                       -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
363
    replaceWithPrePreExisting installPlan
364
      [ (installedUnitId pkg, mipkg)
Duncan Coutts's avatar
Duncan Coutts committed
365
366
      | InstallPlan.Configured pkg
          <- InstallPlan.reverseTopologicalOrder installPlan
367
368
      , let uid = installedUnitId pkg
            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus
369
      , BuildStatusUpToDate (BuildResult { buildResultLibInfo = mipkg })
370
          <- [pkgBuildStatus]
Duncan Coutts's avatar
Duncan Coutts committed
371
372
      ]
  where
373
    replaceWithPrePreExisting =
374
      foldl' (\plan (uid, mipkg) ->
375
376
377
                -- TODO: A grievous hack.  Better to have a special type
                -- of entry representing pre-existing executables.
                let stub_ipkg = Installed.emptyInstalledPackageInfo {
378
                                    Installed.installedUnitId = uid
379
380
                                }
                    ipkg = fromMaybe stub_ipkg mipkg
381
                in InstallPlan.preexisting uid ipkg plan)
Duncan Coutts's avatar
Duncan Coutts committed
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399


-----------------------------
-- 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 (),
400
       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildResultMisc,
401
       pkgFileMonitorReg    :: FileMonitor () (Maybe InstalledPackageInfo)
Duncan Coutts's avatar
Duncan Coutts committed
402
403
     }

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

412
413
newPackageFileMonitor :: DistDirLayout -> DistDirParams -> PackageFileMonitor
newPackageFileMonitor DistDirLayout{distPackageCacheFile} dparams =
Duncan Coutts's avatar
Duncan Coutts committed
414
415
    PackageFileMonitor {
      pkgFileMonitorConfig =
416
        newFileMonitor (distPackageCacheFile dparams "config"),
Duncan Coutts's avatar
Duncan Coutts committed
417
418
419

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

      pkgFileMonitorReg =
427
        newFileMonitor (distPackageCacheFile dparams "registration")
Duncan Coutts's avatar
Duncan Coutts committed
428
429
430
431
432
433
434
435
436
437
    }

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

    -- 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.
    --
459
    buildComponents = elabBuildTargetWholeComponents elab
Duncan Coutts's avatar
Duncan Coutts committed
460
461
462
463
464
465
466

-- | Do all the checks on whether a package has changed and thus needs either
-- rebuilding or reconfiguring and rebuilding.
--
checkPackageFileMonitorChanged :: PackageFileMonitor
                               -> ElaboratedConfiguredPackage
                               -> FilePath
467
                               -> [BuildStatus]
468
                               -> IO (Either BuildStatusRebuild BuildResult)
Duncan Coutts's avatar
Duncan Coutts committed
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
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
          -- of depencencies.
484
        | any buildStatusRequiresBuild depsBuildStatus -> do
Duncan Coutts's avatar
Duncan Coutts committed
485
486
487
488
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
            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

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

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


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

596
597
598
599
600
601
602
603
604
605
606
607
608
609
-- | 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,
610
       buildResultLogFile :: Maybe FilePath,
611
612
613
614
615
616
617
618
619
       -- | 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.).
620
       buildResultLibInfo :: Maybe InstalledPackageInfo
621
622
623
624
625
     }
  deriving Show

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

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

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

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

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

680
681
    createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
    createDirectoryIfMissingVerbose verbosity True distTempDirectory
682
    mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
Duncan Coutts's avatar
Duncan Coutts committed
683
684
685
686
687
688
689

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

696
697
        let uid = installedUnitId pkg
            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in
Duncan Coutts's avatar
Duncan Coutts committed
698
699
700
701
702

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

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

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


    unpackTarballPhase tarball =
        withTarballLocalDirectory
          verbosity distDirLayout tarball
763
764
          (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg)
          (elabPkgDescriptionOverride pkg) $
Duncan Coutts's avatar
Duncan Coutts committed
765

766
          case elabBuildStyle pkg of
Duncan Coutts's avatar
Duncan Coutts committed
767
768
769
770
771
772
773
774
775
776
            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 =
777
        assert (elabBuildStyle pkg == BuildInplaceOnly) $
Duncan Coutts's avatar
Duncan Coutts committed
778
779
780

          buildInplace buildStatus srcdir builddir
      where
781
        builddir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg)
Duncan Coutts's avatar
Duncan Coutts committed
782
783
784
785

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


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




-- | Ensure that the package is unpacked in an appropriate directory, either
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
868
-- a temporary one or a persistent one under the shared dist directory.
Duncan Coutts's avatar
Duncan Coutts committed
869
870
871
872
873
874
--
withTarballLocalDirectory
  :: Verbosity
  -> DistDirLayout
  -> FilePath
  -> PackageId
875
  -> DistDirParams
Duncan Coutts's avatar
Duncan Coutts committed
876
877
  -> BuildStyle
  -> Maybe CabalFileText
878
879
880
  -> (FilePath -> -- Source directory
      FilePath -> -- Build directory
      IO a)
Duncan Coutts's avatar
Duncan Coutts committed
881
882
  -> IO a
withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}
883
                          tarball pkgid dparams buildstyle pkgTextOverride
Duncan Coutts's avatar
Duncan Coutts committed
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
                          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
903
              builddir   = distBuildDirectory dparams
Duncan Coutts's avatar
Duncan Coutts committed
904
905
906
          -- TODO: [nice to have] use a proper file monitor rather than this dir exists test
          exists <- doesDirectoryExist srcdir
          unless exists $ do
907
            createDirectoryIfMissingVerbose verbosity True srcrootdir
Duncan Coutts's avatar
Duncan Coutts committed
908
909
910
            unpackPackageTarball verbosity tarball srcrootdir
                                 pkgid pkgTextOverride
            moveTarballShippedDistDirectory verbosity distDirLayout
911
                                            srcrootdir pkgid dparams
Duncan Coutts's avatar
Duncan Coutts committed
912
913
914
915
916
917
918
919
          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
920
    annotateFailureNoLog UnpackFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
921
922
923
924
925
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

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


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

993
    createDirectoryIfMissingVerbose verbosity True builddir
Duncan Coutts's avatar
Duncan Coutts committed
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
    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

1006
    let dispname = case elabPkgOrComp pkg of
1007
1008
            ElabPackage _ -> display pkgid
            ElabComponent comp -> display pkgid ++ " "
1009
                ++ maybe "custom" display (compComponentName comp)
1010

Duncan Coutts's avatar
Duncan Coutts committed
1011
1012
    -- Configure phase
    when isParallelBuild $
1013
      notice verbosity $ "Configuring " ++ dispname ++ "..."
1014
    annotateFailure mlogFile ConfigureFailed $
1015
      setup' configureCommand configureFlags configureArgs
Duncan Coutts's avatar
Duncan Coutts committed
1016
1017
1018

    -- Build phase
    when isParallelBuild $
1019
      notice verbosity $ "Building " ++ dispname ++ "..."
1020
    annotateFailure mlogFile BuildFailed $
Duncan Coutts's avatar
Duncan Coutts committed
1021
1022
1023
      setup buildCommand buildFlags

    -- Install phase
1024
    mipkg <-
1025
      annotateFailure mlogFile InstallFailed $ do
Duncan Coutts's avatar
Duncan Coutts committed
1026
1027
1028
1029
1030
1031
1032
1033
1034
      --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
1035

Duncan Coutts's avatar
Duncan Coutts committed
1036
      LBS.writeFile
1037
        (InstallDirs.prefix (elabInstallDirs pkg) </> "cabal-hash.txt") $
Duncan Coutts's avatar
Duncan Coutts committed
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
        (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.

1048
      if elabRequiresRegistration pkg
Duncan Coutts's avatar
Duncan Coutts committed
1049
1050
1051
1052
        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.
1053
          ipkg0 <- generateInstalledPackageInfo
1054
          let ipkg = ipkg0 { Installed.installedUnitId = uid }
1055

1056
          criticalSection registerLock $
1057
1058
              Cabal.registerPackage verbosity compiler progdb
                                    HcPkg.MultiInstance
1059
                                    (elabRegisterPackageDBStack pkg) ipkg
1060
1061
          return (Just ipkg)
        else return Nothing
Duncan Coutts's avatar
Duncan Coutts committed
1062
1063
1064
1065
1066

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

1067
1068
1069
    return BuildResult {
       buildResultDocs    = docsResult,
       buildResultTests   = testsResult,
1070
       buildResultLogFile = mlogFile,
1071
       buildResultLibInfo = mipkg
1072
    }
Duncan Coutts's avatar
Duncan Coutts committed
1073
1074
1075

  where
    pkgid  = packageId rpkg
1076
    uid = installedUnitId rpkg
Duncan Coutts's avatar
Duncan Coutts committed
1077
1078
1079

    isParallelBuild = buildSettingNumJobs >= 2

1080
    configureCommand = Cabal.configureCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
1081
1082
1083
    configureFlags v = flip filterConfigureFlags v $
                       setupHsConfigureFlags rpkg pkgshared
                                             verbosity builddir
1084
    configureArgs    = setupHsConfigureArgs pkg
Duncan Coutts's avatar
Duncan Coutts committed
1085

1086
    buildCommand     = Cabal.buildCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
1087
1088
    buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir

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

    copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir

    scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir
                                         isParallelBuild cacheLock

    setup :: CommandUI flags -> (Version -> flags) -> IO ()
1105
1106
1107
1108
    setup cmd flags = setup' cmd flags []

    setup' :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()
    setup' cmd flags args =
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
1109
      withLogging $ \mLogFileHandle ->
Duncan Coutts's avatar
Duncan Coutts committed
1110
1111
1112
        setupWrapper
          verbosity
          scriptOptions { useLoggingHandle = mLogFileHandle }
1113
          (Just (elabPkgDescription pkg))
1114
          cmd flags args
Duncan Coutts's avatar
Duncan Coutts committed
1115

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

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

        -- Configure phase
        --
        whenReConfigure $ do
1167
          annotateFailureNoLog ConfigureFailed $
1168
            setup configureCommand configureFlags configureArgs
Duncan Coutts's avatar
Duncan Coutts committed
1169
1170
1171
1172
1173
1174
1175
1176
          invalidatePackageRegFileMonitor packageFileMonitor
          updatePackageConfigFileMonitor packageFileMonitor srcdir pkg

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

1177
1178
            buildResult :: BuildResultMisc
            buildResult = (docsResult, testsResult)
Duncan Coutts's avatar
Duncan Coutts committed
1179
1180
1181

        whenRebuild $ do
          timestamp <- beginUpdateFileMonitor
1182
          annotateFailureNoLog BuildFailed $
1183
            setup buildCommand buildFlags buildArgs
Duncan Coutts's avatar
Duncan Coutts committed
1184

1185
1186
1187
          --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.
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
          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
1204
1205
1206

          updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp
                                        pkg buildStatus
1207
                                        allSrcFiles buildResult
Duncan Coutts's avatar
Duncan Coutts committed
1208

1209
1210
        -- PURPOSELY omitted: no copy!

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

1227
           else return Nothing
1228

1229
1230
          updatePackageRegFileMonitor packageFileMonitor srcdir mipkg
          return mipkg
Duncan Coutts's avatar
Duncan Coutts committed
1231
1232
1233
1234

        -- Repl phase
        --
        whenRepl $
1235
          annotateFailureNoLog ReplFailed $
Duncan Coutts's avatar
Duncan Coutts committed
1236
1237
1238
1239
          setup replCommand replFlags replArgs

        -- Haddock phase
        whenHaddock $
1240
          annotateFailureNoLog HaddocksFailed $
Duncan Coutts's avatar
Duncan Coutts committed
1241
1242
          setup haddockCommand haddockFlags []

1243
1244
1245
        return BuildResult {
          buildResultDocs    = docsResult,
          buildResultTests   = testsResult,
1246
          buildResultLogFile = Nothing,
1247
          buildResultLibInfo = mipkg
1248
        }
Duncan Coutts's avatar
Duncan Coutts committed
1249
1250

  where
1251
1252
    ipkgid  = installedUnitId pkg
    dparams = elabDistDirParams pkgshared pkg
Duncan Coutts's avatar
Duncan Coutts committed
1253
1254
1255

    isParallelBuild = buildSettingNumJobs >= 2

1256
    packageFileMonitor = newPackageFileMonitor distDirLayout dparams
Duncan Coutts's avatar
Duncan Coutts committed
1257
1258
1259
1260
1261
1262

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

    whenRebuild action
1263
      | null (elabBuildTargets pkg) = return ()
Duncan Coutts's avatar
Duncan Coutts committed
1264
1265
1266
      | otherwise                  = action

    whenRepl action
1267
      | isNothing (elabReplTarget pkg) = return ()
Duncan Coutts's avatar
Duncan Coutts committed
1268
1269
1270
      | otherwise                     = action

    whenHaddock action
1271
      | elabBuildHaddocks pkg = action
Duncan Coutts's avatar
Duncan Coutts committed
1272
1273
1274
1275
1276
      | otherwise            = return ()

    whenReRegister  action = case buildStatus of
      BuildStatusConfigure          _ -> action
      BuildStatusBuild Nothing      _ -> action
1277
      BuildStatusBuild (Just mipkg) _ -> return mipkg
Duncan Coutts's avatar
Duncan Coutts committed
1278

1279
    configureCommand = Cabal.configureCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
1280
1281
1282
    configureFlags v = flip filterConfigureFlags v $
                       setupHsConfigureFlags rpkg pkgshared
                                             verbosity builddir
1283
    configureArgs    = setupHsConfigureArgs pkg
Duncan Coutts's avatar
Duncan Coutts committed
1284

1285
    buildCommand     = Cabal.buildCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
1286
1287
1288
1289
    buildFlags   _   = setupHsBuildFlags pkg pkgshared
                                         verbosity builddir
    buildArgs        = setupHsBuildArgs  pkg

1290
    replCommand      = Cabal.replCommand defaultProgramDb
Duncan Coutts's avatar
Duncan Coutts committed
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
    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

    setup :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()
    setup cmd flags args =
      setupWrapper verbosity
                   scriptOptions
1307
                   (Just (elabPkgDescription pkg))
Duncan Coutts's avatar
Duncan Coutts committed
1308
1309
                   cmd flags args

1310
1311
1312
    generateInstalledPackageInfo :: IO InstalledPackageInfo
    generateInstalledPackageInfo =
      withTempInstalledPackageInfoFile
1313
        verbosity distTempDirectory $ \pkgConfDest -> do
Duncan Coutts's avatar
Duncan Coutts committed
1314
1315
1316
        let registerFlags _ = setupHsRegisterFlags
                                pkg pkgshared
                                verbosity builddir
1317
                                pkgConfDest
Duncan Coutts's avatar
Duncan Coutts committed
1318
1319
1320
1321
        setup Cabal.registerCommand registerFlags []