1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE ConstraintKinds #-} 4{-# LANGUAGE NamedFieldPuns #-} 5{-# LANGUAGE NoMonoLocalBinds #-} 6{-# LANGUAGE RecordWildCards #-} 7{-# LANGUAGE ScopedTypeVariables #-} 8{-# LANGUAGE TypeFamilies #-} 9 10-- | 11-- 12module Distribution.Client.ProjectBuilding ( 13 -- * Dry run phase 14 -- | What bits of the plan will we execute? The dry run does not change 15 -- anything but tells us what will need to be built. 16 rebuildTargetsDryRun, 17 improveInstallPlanWithUpToDatePackages, 18 19 -- ** Build status 20 -- | This is the detailed status information we get from the dry run. 21 BuildStatusMap, 22 BuildStatus(..), 23 BuildStatusRebuild(..), 24 BuildReason(..), 25 MonitorChangedReason(..), 26 buildStatusToString, 27 28 -- * Build phase 29 -- | Now we actually execute the plan. 30 rebuildTargets, 31 -- ** Build outcomes 32 -- | This is the outcome for each package of executing the plan. 33 -- For each package, did the build succeed or fail? 34 BuildOutcomes, 35 BuildOutcome, 36 BuildResult(..), 37 BuildFailure(..), 38 BuildFailureReason(..), 39 ) where 40 41import Distribution.Client.Compat.Prelude 42import Prelude () 43 44import Distribution.Client.PackageHash (renderPackageHashInputs) 45import Distribution.Client.RebuildMonad 46import Distribution.Client.ProjectConfig 47import Distribution.Client.ProjectPlanning 48import Distribution.Client.ProjectPlanning.Types 49import Distribution.Client.ProjectBuilding.Types 50import Distribution.Client.Store 51 52import Distribution.Client.Types 53 hiding (BuildOutcomes, BuildOutcome, 54 BuildResult(..), BuildFailure(..)) 55import Distribution.Client.InstallPlan 56 ( GenericInstallPlan, GenericPlanPackage, IsUnit ) 57import qualified Distribution.Client.InstallPlan as InstallPlan 58import Distribution.Client.DistDirLayout 59import Distribution.Client.FileMonitor 60import Distribution.Client.SetupWrapper 61import Distribution.Client.JobControl 62import Distribution.Client.FetchUtils 63import Distribution.Client.GlobalFlags (RepoContext) 64import qualified Distribution.Client.Tar as Tar 65import Distribution.Client.Setup 66 ( filterConfigureFlags, filterHaddockArgs 67 , filterHaddockFlags, filterTestFlags ) 68import Distribution.Client.SourceFiles 69import Distribution.Client.SrcDist (allPackageSourceFiles) 70import Distribution.Client.Utils 71 ( ProgressPhase(..), progressMessage, removeExistingFile ) 72 73import Distribution.Compat.Lens 74import Distribution.Package 75import qualified Distribution.PackageDescription as PD 76import Distribution.InstalledPackageInfo (InstalledPackageInfo) 77import qualified Distribution.InstalledPackageInfo as Installed 78import Distribution.Simple.BuildPaths (haddockDirName) 79import qualified Distribution.Simple.InstallDirs as InstallDirs 80import Distribution.Types.BuildType 81import Distribution.Types.PackageDescription.Lens (componentModules) 82import Distribution.Simple.Program 83import qualified Distribution.Simple.Setup as Cabal 84import Distribution.Simple.Command (CommandUI) 85import qualified Distribution.Simple.Register as Cabal 86import Distribution.Simple.LocalBuildInfo 87 ( ComponentName(..), LibraryName(..) ) 88import Distribution.Simple.Compiler 89 ( Compiler, compilerId, PackageDB(..) ) 90 91import Distribution.Simple.Utils 92import Distribution.Version 93import Distribution.Compat.Graph (IsNode(..)) 94 95import qualified Data.List.NonEmpty as NE 96import qualified Data.Map as Map 97import qualified Data.Set as Set 98import qualified Data.ByteString as BS 99import qualified Data.ByteString.Lazy as LBS 100 101import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle) 102import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) 103import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>)) 104import System.IO (IOMode (AppendMode), withFile) 105 106import Distribution.Compat.Directory (listDirectory) 107 108 109------------------------------------------------------------------------------ 110-- * Overall building strategy. 111------------------------------------------------------------------------------ 112-- 113-- We start with an 'ElaboratedInstallPlan' that has already been improved by 114-- reusing packages from the store, and pruned to include only the targets of 115-- interest and their dependencies. So the remaining packages in the 116-- 'InstallPlan.Configured' state are ones we either need to build or rebuild. 117-- 118-- First, we do a preliminary dry run phase where we work out which packages 119-- we really need to (re)build, and for the ones we do need to build which 120-- build phase to start at. 121-- 122-- We use this to improve the 'ElaboratedInstallPlan' again by changing 123-- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed' 124-- so that the build phase will skip them. 125-- 126-- Then we execute the plan, that is actually build packages. The outcomes of 127-- trying to build all the packages are collected and returned. 128-- 129-- We split things like this (dry run and execute) for a couple reasons. 130-- Firstly we need to be able to do dry runs anyway, and these need to be 131-- reasonably accurate in terms of letting users know what (and why) things 132-- are going to be (re)built. 133-- 134-- Given that we need to be able to do dry runs, it would not be great if 135-- we had to repeat all the same work when we do it for real. Not only is 136-- it duplicate work, but it's duplicate code which is likely to get out of 137-- sync. So we do things only once. We preserve info we discover in the dry 138-- run phase and rely on it later when we build things for real. This also 139-- somewhat simplifies the build phase. So this way the dry run can't so 140-- easily drift out of sync with the real thing since we're relying on the 141-- info it produces. 142-- 143-- An additional advantage is that it makes it easier to debug rebuild 144-- errors (ie rebuilding too much or too little), since all the rebuild 145-- decisions are made without making any state changes at the same time 146-- (that would make it harder to reproduce the problem situation). 147-- 148-- Finally, we can use the dry run build status and the build outcomes to 149-- give us some information on the overall status of packages in the project. 150-- This includes limited information about the status of things that were 151-- not actually in the subset of the plan that was used for the dry run or 152-- execution phases. In particular we may know that some packages are now 153-- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for 154-- details. 155 156 157------------------------------------------------------------------------------ 158-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute? 159------------------------------------------------------------------------------ 160 161-- Refer to ProjectBuilding.Types for details of these important types: 162 163-- type BuildStatusMap = ... 164-- data BuildStatus = ... 165-- data BuildStatusRebuild = ... 166-- data BuildReason = ... 167 168-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'. 169-- 170-- It gives us the 'BuildStatusMap'. This should be used with 171-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of 172-- the 'ElaboratedInstallPlan' with packages switched to the 173-- 'InstallPlan.Installed' state when we find that they're already up to date. 174-- 175rebuildTargetsDryRun :: DistDirLayout 176 -> ElaboratedSharedConfig 177 -> ElaboratedInstallPlan 178 -> IO BuildStatusMap 179rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = 180 -- Do the various checks to work out the 'BuildStatus' of each package 181 foldMInstallPlanDepOrder dryRunPkg 182 where 183 dryRunPkg :: ElaboratedPlanPackage 184 -> [BuildStatus] 185 -> IO BuildStatus 186 dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus = 187 return BuildStatusPreExisting 188 189 dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus = 190 return BuildStatusInstalled 191 192 dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do 193 mloc <- checkFetched (elabPkgSourceLocation pkg) 194 case mloc of 195 Nothing -> return BuildStatusDownload 196 197 Just (LocalUnpackedPackage srcdir) -> 198 -- For the case of a user-managed local dir, irrespective of the 199 -- build style, we build from that directory and put build 200 -- artifacts under the shared dist directory. 201 dryRunLocalPkg pkg depsBuildStatus srcdir 202 203 -- The rest cases are all tarball cases are, 204 -- and handled the same as each other though depending on the build style. 205 Just (LocalTarballPackage tarball) -> 206 dryRunTarballPkg pkg depsBuildStatus tarball 207 208 Just (RemoteTarballPackage _ tarball) -> 209 dryRunTarballPkg pkg depsBuildStatus tarball 210 211 Just (RepoTarballPackage _ _ tarball) -> 212 dryRunTarballPkg pkg depsBuildStatus tarball 213 214 Just (RemoteSourceRepoPackage _repo tarball) -> 215 dryRunTarballPkg pkg depsBuildStatus tarball 216 217 218 dryRunTarballPkg :: ElaboratedConfiguredPackage 219 -> [BuildStatus] 220 -> FilePath 221 -> IO BuildStatus 222 dryRunTarballPkg pkg depsBuildStatus tarball = 223 case elabBuildStyle pkg of 224 BuildAndInstall -> return (BuildStatusUnpack tarball) 225 BuildInplaceOnly -> do 226 -- TODO: [nice to have] use a proper file monitor rather 227 -- than this dir exists test 228 exists <- doesDirectoryExist srcdir 229 if exists 230 then dryRunLocalPkg pkg depsBuildStatus srcdir 231 else return (BuildStatusUnpack tarball) 232 where 233 srcdir = distUnpackedSrcDirectory (packageId pkg) 234 235 dryRunLocalPkg :: ElaboratedConfiguredPackage 236 -> [BuildStatus] 237 -> FilePath 238 -> IO BuildStatus 239 dryRunLocalPkg pkg depsBuildStatus srcdir = do 240 -- Go and do lots of I/O, reading caches and probing files to work out 241 -- if anything has changed 242 change <- checkPackageFileMonitorChanged 243 packageFileMonitor pkg srcdir depsBuildStatus 244 case change of 245 -- It did change, giving us 'BuildStatusRebuild' info on why 246 Left rebuild -> 247 return (BuildStatusRebuild srcdir rebuild) 248 249 -- No changes, the package is up to date. Use the saved build results. 250 Right buildResult -> 251 return (BuildStatusUpToDate buildResult) 252 where 253 packageFileMonitor = 254 newPackageFileMonitor shared distDirLayout 255 (elabDistDirParams shared pkg) 256 257 258-- | A specialised traversal over the packages in an install plan. 259-- 260-- The packages are visited in dependency order, starting with packages with no 261-- dependencies. The result for each package is accumulated into a 'Map' and 262-- returned as the final result. In addition, when visiting a package, the 263-- visiting function is passed the results for all the immediate package 264-- dependencies. This can be used to propagate information from dependencies. 265-- 266foldMInstallPlanDepOrder 267 :: forall m ipkg srcpkg b. 268 (Monad m, IsUnit ipkg, IsUnit srcpkg) 269 => (GenericPlanPackage ipkg srcpkg -> 270 [b] -> m b) 271 -> GenericInstallPlan ipkg srcpkg 272 -> m (Map UnitId b) 273foldMInstallPlanDepOrder visit = 274 go Map.empty . InstallPlan.reverseTopologicalOrder 275 where 276 go :: Map UnitId b 277 -> [GenericPlanPackage ipkg srcpkg] 278 -> m (Map UnitId b) 279 go !results [] = return results 280 281 go !results (pkg : pkgs) = do 282 -- we go in the right order so the results map has entries for all deps 283 let depresults :: [b] 284 depresults = 285 map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results 286 in result) 287 (InstallPlan.depends pkg) 288 result <- visit pkg depresults 289 let results' = Map.insert (nodeKey pkg) result results 290 go results' pkgs 291 292improveInstallPlanWithUpToDatePackages :: BuildStatusMap 293 -> ElaboratedInstallPlan 294 -> ElaboratedInstallPlan 295improveInstallPlanWithUpToDatePackages pkgsBuildStatus = 296 InstallPlan.installed canPackageBeImproved 297 where 298 canPackageBeImproved pkg = 299 case Map.lookup (installedUnitId pkg) pkgsBuildStatus of 300 Just BuildStatusUpToDate {} -> True 301 Just _ -> False 302 Nothing -> error $ "improveInstallPlanWithUpToDatePackages: " 303 ++ prettyShow (packageId pkg) ++ " not in status map" 304 305 306----------------------------- 307-- Package change detection 308-- 309 310-- | As part of the dry run for local unpacked packages we have to check if the 311-- package config or files have changed. That is the purpose of 312-- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'. 313-- 314-- When a package is (re)built, the monitor must be updated to reflect the new 315-- state of the package. Because we sometimes build without reconfiguring the 316-- state updates are split into two, one for package config changes and one 317-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' 318-- and 'updatePackageBuildFileMonitor'. 319-- 320data PackageFileMonitor = PackageFileMonitor { 321 pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), 322 pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc, 323 pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) 324 } 325 326-- | This is all the components of the 'BuildResult' other than the 327-- @['InstalledPackageInfo']@. 328-- 329-- We have to split up the 'BuildResult' components since they get produced 330-- at different times (or rather, when different things change). 331-- 332type BuildResultMisc = (DocsResult, TestsResult) 333 334newPackageFileMonitor :: ElaboratedSharedConfig 335 -> DistDirLayout 336 -> DistDirParams 337 -> PackageFileMonitor 338newPackageFileMonitor shared 339 DistDirLayout{distPackageCacheFile} 340 dparams = 341 PackageFileMonitor { 342 pkgFileMonitorConfig = 343 FileMonitor { 344 fileMonitorCacheFile = distPackageCacheFile dparams "config", 345 fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared, 346 fileMonitorCheckIfOnlyValueChanged = False 347 }, 348 349 pkgFileMonitorBuild = 350 FileMonitor { 351 fileMonitorCacheFile = distPackageCacheFile dparams "build", 352 fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> 353 componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt, 354 fileMonitorCheckIfOnlyValueChanged = True 355 }, 356 357 pkgFileMonitorReg = 358 newFileMonitor (distPackageCacheFile dparams "registration") 359 } 360 361-- | Helper function for 'checkPackageFileMonitorChanged', 362-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'. 363-- 364-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by 365-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes. 366-- 367packageFileMonitorKeyValues :: ElaboratedConfiguredPackage 368 -> (ElaboratedConfiguredPackage, Set ComponentName) 369packageFileMonitorKeyValues elab = 370 (elab_config, buildComponents) 371 where 372 -- The first part is the value used to guard (re)configuring the package. 373 -- That is, if this value changes then we will reconfigure. 374 -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of 375 -- information that affects the (re)configure step. But those parts that 376 -- do not affect the configure step need to be nulled out. Those parts are 377 -- the specific targets that we're going to build. 378 -- 379 elab_config = 380 elab { 381 elabBuildTargets = [], 382 elabTestTargets = [], 383 elabBenchTargets = [], 384 elabReplTarget = Nothing, 385 elabHaddockTargets = [], 386 elabBuildHaddocks = False 387 } 388 389 -- The second part is the value used to guard the build step. So this is 390 -- more or less the opposite of the first part, as it's just the info about 391 -- what targets we're going to build. 392 -- 393 buildComponents = elabBuildTargetWholeComponents elab 394 395-- | Do all the checks on whether a package has changed and thus needs either 396-- rebuilding or reconfiguring and rebuilding. 397-- 398checkPackageFileMonitorChanged :: PackageFileMonitor 399 -> ElaboratedConfiguredPackage 400 -> FilePath 401 -> [BuildStatus] 402 -> IO (Either BuildStatusRebuild BuildResult) 403checkPackageFileMonitorChanged PackageFileMonitor{..} 404 pkg srcdir depsBuildStatus = do 405 --TODO: [nice to have] some debug-level message about file 406 --changes, like rerunIfChanged 407 configChanged <- checkFileMonitorChanged 408 pkgFileMonitorConfig srcdir pkgconfig 409 case configChanged of 410 MonitorChanged monitorReason -> 411 return (Left (BuildStatusConfigure monitorReason')) 412 where 413 monitorReason' = fmap (const ()) monitorReason 414 415 MonitorUnchanged () _ 416 -- The configChanged here includes the identity of the dependencies, 417 -- so depsBuildStatus is just needed for the changes in the content 418 -- of dependencies. 419 | any buildStatusRequiresBuild depsBuildStatus -> do 420 regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () 421 let mreg = changedToMaybe regChanged 422 return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) 423 424 | otherwise -> do 425 buildChanged <- checkFileMonitorChanged 426 pkgFileMonitorBuild srcdir buildComponents 427 regChanged <- checkFileMonitorChanged 428 pkgFileMonitorReg srcdir () 429 let mreg = changedToMaybe regChanged 430 case (buildChanged, regChanged) of 431 (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> 432 return (Left (BuildStatusBuild mreg buildReason)) 433 where 434 buildReason = BuildReasonExtraTargets prevBuildComponents 435 436 (MonitorChanged monitorReason, _) -> 437 return (Left (BuildStatusBuild mreg buildReason)) 438 where 439 buildReason = BuildReasonFilesChanged monitorReason' 440 monitorReason' = fmap (const ()) monitorReason 441 442 (MonitorUnchanged _ _, MonitorChanged monitorReason) -> 443 -- this should only happen if the file is corrupt or been 444 -- manually deleted. We don't want to bother with another 445 -- phase just for this, so we'll reregister by doing a build. 446 return (Left (BuildStatusBuild Nothing buildReason)) 447 where 448 buildReason = BuildReasonFilesChanged monitorReason' 449 monitorReason' = fmap (const ()) monitorReason 450 451 (MonitorUnchanged _ _, MonitorUnchanged _ _) 452 | pkgHasEphemeralBuildTargets pkg -> 453 return (Left (BuildStatusBuild mreg buildReason)) 454 where 455 buildReason = BuildReasonEphemeralTargets 456 457 (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> 458 return $ Right BuildResult { 459 buildResultDocs = docsResult, 460 buildResultTests = testsResult, 461 buildResultLogFile = Nothing 462 } 463 where 464 (docsResult, testsResult) = buildResult 465 where 466 (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg 467 changedToMaybe (MonitorChanged _) = Nothing 468 changedToMaybe (MonitorUnchanged x _) = Just x 469 470 471updatePackageConfigFileMonitor :: PackageFileMonitor 472 -> FilePath 473 -> ElaboratedConfiguredPackage 474 -> IO () 475updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig} 476 srcdir pkg = 477 updateFileMonitor pkgFileMonitorConfig srcdir Nothing 478 [] pkgconfig () 479 where 480 (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg 481 482updatePackageBuildFileMonitor :: PackageFileMonitor 483 -> FilePath 484 -> MonitorTimestamp 485 -> ElaboratedConfiguredPackage 486 -> BuildStatusRebuild 487 -> [MonitorFilePath] 488 -> BuildResultMisc 489 -> IO () 490updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} 491 srcdir timestamp pkg pkgBuildStatus 492 monitors buildResult = 493 updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp) 494 monitors buildComponents' buildResult 495 where 496 (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg 497 498 -- If the only thing that's changed is that we're now building extra 499 -- components, then we can avoid later unnecessary rebuilds by saving the 500 -- total set of components that have been built, namely the union of the 501 -- existing ones plus the new ones. If files also changed this would be 502 -- the wrong thing to do. Note that we rely on the 503 -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee 504 -- that it's /only/ the value that changed not any files that changed. 505 buildComponents' = 506 case pkgBuildStatus of 507 BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) 508 -> buildComponents `Set.union` prevBuildComponents 509 _ -> buildComponents 510 511updatePackageRegFileMonitor :: PackageFileMonitor 512 -> FilePath 513 -> Maybe InstalledPackageInfo 514 -> IO () 515updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} 516 srcdir mipkg = 517 updateFileMonitor pkgFileMonitorReg srcdir Nothing 518 [] () mipkg 519 520invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () 521invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = 522 removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) 523 524 525------------------------------------------------------------------------------ 526-- * Doing it: executing an 'ElaboratedInstallPlan' 527------------------------------------------------------------------------------ 528 529-- Refer to ProjectBuilding.Types for details of these important types: 530 531-- type BuildOutcomes = ... 532-- type BuildOutcome = ... 533-- data BuildResult = ... 534-- data BuildFailure = ... 535-- data BuildFailureReason = ... 536 537-- | Build things for real. 538-- 539-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'. 540-- 541rebuildTargets :: Verbosity 542 -> DistDirLayout 543 -> StoreDirLayout 544 -> ElaboratedInstallPlan 545 -> ElaboratedSharedConfig 546 -> BuildStatusMap 547 -> BuildTimeSettings 548 -> IO BuildOutcomes 549rebuildTargets verbosity 550 distDirLayout@DistDirLayout{..} 551 storeDirLayout 552 installPlan 553 sharedPackageConfig@ElaboratedSharedConfig { 554 pkgConfigCompiler = compiler, 555 pkgConfigCompilerProgs = progdb 556 } 557 pkgsBuildStatus 558 buildSettings@BuildTimeSettings{ 559 buildSettingNumJobs, 560 buildSettingKeepGoing 561 } = do 562 563 -- Concurrency control: create the job controller and concurrency limits 564 -- for downloading, building and installing. 565 jobControl <- if isParallelBuild 566 then newParallelJobControl buildSettingNumJobs 567 else newSerialJobControl 568 registerLock <- newLock -- serialise registration 569 cacheLock <- newLock -- serialise access to setup exe cache 570 --TODO: [code cleanup] eliminate setup exe cache 571 572 debug verbosity $ 573 "Executing install plan " 574 ++ if isParallelBuild 575 then " in parallel using " ++ show buildSettingNumJobs ++ " threads." 576 else " serially." 577 578 createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory 579 createDirectoryIfMissingVerbose verbosity True distTempDirectory 580 traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse 581 582 -- Before traversing the install plan, pre-emptively find all packages that 583 -- will need to be downloaded and start downloading them. 584 asyncDownloadPackages verbosity withRepoCtx 585 installPlan pkgsBuildStatus $ \downloadMap -> 586 587 -- For each package in the plan, in dependency order, but in parallel... 588 InstallPlan.execute jobControl keepGoing 589 (BuildFailure Nothing . DependentFailed . packageId) 590 installPlan $ \pkg -> 591 --TODO: review exception handling 592 handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ 593 594 let uid = installedUnitId pkg 595 pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in 596 597 rebuildTarget 598 verbosity 599 distDirLayout 600 storeDirLayout 601 buildSettings downloadMap 602 registerLock cacheLock 603 sharedPackageConfig 604 installPlan pkg 605 pkgBuildStatus 606 where 607 isParallelBuild = buildSettingNumJobs >= 2 608 keepGoing = buildSettingKeepGoing 609 withRepoCtx = projectConfigWithBuilderRepoContext verbosity 610 buildSettings 611 packageDBsToUse = -- all the package dbs we may need to create 612 (Set.toList . Set.fromList) 613 [ pkgdb 614 | InstallPlan.Configured elab <- InstallPlan.toList installPlan 615 , pkgdb <- concat [ elabBuildPackageDBStack elab 616 , elabRegisterPackageDBStack elab 617 , elabSetupPackageDBStack elab ] 618 ] 619 620 621-- | Create a package DB if it does not currently exist. Note that this action 622-- is /not/ safe to run concurrently. 623-- 624createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb 625 -> PackageDB -> IO () 626createPackageDBIfMissing verbosity compiler progdb 627 (SpecificPackageDB dbPath) = do 628 exists <- Cabal.doesPackageDBExist dbPath 629 unless exists $ do 630 createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) 631 Cabal.createPackageDB verbosity compiler progdb False dbPath 632createPackageDBIfMissing _ _ _ _ = return () 633 634 635-- | Given all the context and resources, (re)build an individual package. 636-- 637rebuildTarget :: Verbosity 638 -> DistDirLayout 639 -> StoreDirLayout 640 -> BuildTimeSettings 641 -> AsyncFetchMap 642 -> Lock -> Lock 643 -> ElaboratedSharedConfig 644 -> ElaboratedInstallPlan 645 -> ElaboratedReadyPackage 646 -> BuildStatus 647 -> IO BuildResult 648rebuildTarget verbosity 649 distDirLayout@DistDirLayout{distBuildDirectory} 650 storeDirLayout 651 buildSettings downloadMap 652 registerLock cacheLock 653 sharedPackageConfig 654 plan rpkg@(ReadyPackage pkg) 655 pkgBuildStatus = 656 657 -- We rely on the 'BuildStatus' to decide which phase to start from: 658 case pkgBuildStatus of 659 BuildStatusDownload -> downloadPhase 660 BuildStatusUnpack tarball -> unpackTarballPhase tarball 661 BuildStatusRebuild srcdir status -> rebuildPhase status srcdir 662 663 -- TODO: perhaps re-nest the types to make these impossible 664 BuildStatusPreExisting {} -> unexpectedState 665 BuildStatusInstalled {} -> unexpectedState 666 BuildStatusUpToDate {} -> unexpectedState 667 where 668 unexpectedState = error "rebuildTarget: unexpected package status" 669 670 downloadPhase = do 671 downsrcloc <- annotateFailureNoLog DownloadFailed $ 672 waitAsyncPackageDownload verbosity downloadMap pkg 673 case downsrcloc of 674 DownloadedTarball tarball -> unpackTarballPhase tarball 675 --TODO: [nice to have] git/darcs repos etc 676 677 678 unpackTarballPhase tarball = 679 withTarballLocalDirectory 680 verbosity distDirLayout tarball 681 (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) 682 (elabBuildStyle pkg) 683 (elabPkgDescriptionOverride pkg) $ 684 685 case elabBuildStyle pkg of 686 BuildAndInstall -> buildAndInstall 687 BuildInplaceOnly -> buildInplace buildStatus 688 where 689 buildStatus = BuildStatusConfigure MonitorFirstRun 690 691 -- Note that this really is rebuild, not build. It can only happen for 692 -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages 693 -- would only start from download or unpack phases. 694 -- 695 rebuildPhase buildStatus srcdir = 696 assert (elabBuildStyle pkg == BuildInplaceOnly) $ 697 698 buildInplace buildStatus srcdir builddir 699 where 700 builddir = distBuildDirectory 701 (elabDistDirParams sharedPackageConfig pkg) 702 703 buildAndInstall srcdir builddir = 704 buildAndInstallUnpackedPackage 705 verbosity distDirLayout storeDirLayout 706 buildSettings registerLock cacheLock 707 sharedPackageConfig 708 plan rpkg 709 srcdir builddir' 710 where 711 builddir' = makeRelative srcdir builddir 712 --TODO: [nice to have] ^^ do this relative stuff better 713 714 buildInplace buildStatus srcdir builddir = 715 --TODO: [nice to have] use a relative build dir rather than absolute 716 buildInplaceUnpackedPackage 717 verbosity distDirLayout 718 buildSettings registerLock cacheLock 719 sharedPackageConfig 720 plan rpkg 721 buildStatus 722 srcdir builddir 723 724-- TODO: [nice to have] do we need to use a with-style for the temp 725-- files for downloading http packages, or are we going to cache them 726-- persistently? 727 728-- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the 729-- packages we have to download and fork off an async action to download them. 730-- We download them in dependency order so that the one's we'll need 731-- first are the ones we will start downloading first. 732-- 733-- The body action is passed a map from those packages (identified by their 734-- location) to a completion var for that package. So the body action should 735-- lookup the location and use 'waitAsyncPackageDownload' to get the result. 736-- 737asyncDownloadPackages :: Verbosity 738 -> ((RepoContext -> IO a) -> IO a) 739 -> ElaboratedInstallPlan 740 -> BuildStatusMap 741 -> (AsyncFetchMap -> IO a) 742 -> IO a 743asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body 744 | null pkgsToDownload = body Map.empty 745 | otherwise = withRepoCtx $ \repoctx -> 746 asyncFetchPackages verbosity repoctx 747 pkgsToDownload body 748 where 749 pkgsToDownload = 750 ordNub $ 751 [ elabPkgSourceLocation elab 752 | InstallPlan.Configured elab 753 <- InstallPlan.reverseTopologicalOrder installPlan 754 , let uid = installedUnitId elab 755 pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus 756 , BuildStatusDownload <- [pkgBuildStatus] 757 ] 758 759 760-- | Check if a package needs downloading, and if so expect to find a download 761-- in progress in the given 'AsyncFetchMap' and wait on it to finish. 762-- 763waitAsyncPackageDownload :: Verbosity 764 -> AsyncFetchMap 765 -> ElaboratedConfiguredPackage 766 -> IO DownloadedSourceLocation 767waitAsyncPackageDownload verbosity downloadMap elab = do 768 pkgloc <- waitAsyncFetchPackage verbosity downloadMap 769 (elabPkgSourceLocation elab) 770 case downloadedSourceLocation pkgloc of 771 Just loc -> return loc 772 Nothing -> fail "waitAsyncPackageDownload: unexpected source location" 773 774data DownloadedSourceLocation = DownloadedTarball FilePath 775 --TODO: [nice to have] git/darcs repos etc 776 777downloadedSourceLocation :: PackageLocation FilePath 778 -> Maybe DownloadedSourceLocation 779downloadedSourceLocation pkgloc = 780 case pkgloc of 781 RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) 782 RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) 783 _ -> Nothing 784 785 786 787 788-- | Ensure that the package is unpacked in an appropriate directory, either 789-- a temporary one or a persistent one under the shared dist directory. 790-- 791withTarballLocalDirectory 792 :: Verbosity 793 -> DistDirLayout 794 -> FilePath 795 -> PackageId 796 -> DistDirParams 797 -> BuildStyle 798 -> Maybe CabalFileText 799 -> (FilePath -> -- Source directory 800 FilePath -> -- Build directory 801 IO a) 802 -> IO a 803withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} 804 tarball pkgid dparams buildstyle pkgTextOverride 805 buildPkg = 806 case buildstyle of 807 -- In this case we make a temp dir (e.g. tmp/src2345/), unpack 808 -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for 809 -- compatibility we put the dist dir within it 810 -- (i.e. tmp/src2345/foo-1.0/dist/). 811 -- 812 -- Unfortunately, a few custom Setup.hs scripts do not respect 813 -- the --builddir flag and always look for it at ./dist/ so 814 -- this way we avoid breaking those packages 815 BuildAndInstall -> 816 let tmpdir = distTempDirectory in 817 withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do 818 unpackPackageTarball verbosity tarball unpackdir 819 pkgid pkgTextOverride 820 let srcdir = unpackdir </> prettyShow pkgid 821 builddir = srcdir </> "dist" 822 buildPkg srcdir builddir 823 824 -- In this case we make sure the tarball has been unpacked to the 825 -- appropriate location under the shared dist dir, and then build it 826 -- inplace there 827 BuildInplaceOnly -> do 828 let srcrootdir = distUnpackedSrcRootDirectory 829 srcdir = distUnpackedSrcDirectory pkgid 830 builddir = distBuildDirectory dparams 831 -- TODO: [nice to have] use a proper file monitor rather 832 -- than this dir exists test 833 exists <- doesDirectoryExist srcdir 834 unless exists $ do 835 createDirectoryIfMissingVerbose verbosity True srcrootdir 836 unpackPackageTarball verbosity tarball srcrootdir 837 pkgid pkgTextOverride 838 moveTarballShippedDistDirectory verbosity distDirLayout 839 srcrootdir pkgid dparams 840 buildPkg srcdir builddir 841 842 843unpackPackageTarball :: Verbosity -> FilePath -> FilePath 844 -> PackageId -> Maybe CabalFileText 845 -> IO () 846unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = 847 --TODO: [nice to have] switch to tar package and catch tar exceptions 848 annotateFailureNoLog UnpackFailed $ do 849 850 -- Unpack the tarball 851 -- 852 info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." 853 Tar.extractTarGzFile parentdir pkgsubdir tarball 854 855 -- Sanity check 856 -- 857 exists <- doesFileExist cabalFile 858 unless exists $ 859 die' verbosity $ 860 "Package .cabal file not found in the tarball: " ++ cabalFile 861 862 -- Overwrite the .cabal with the one from the index, when appropriate 863 -- 864 case pkgTextOverride of 865 Nothing -> return () 866 Just pkgtxt -> do 867 info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal" 868 ++ " with the latest revision from the index." 869 writeFileAtomic cabalFile pkgtxt 870 871 where 872 cabalFile = parentdir </> pkgsubdir 873 </> prettyShow pkgname <.> "cabal" 874 pkgsubdir = prettyShow pkgid 875 pkgname = packageName pkgid 876 877 878-- | This is a bit of a hacky workaround. A number of packages ship 879-- pre-processed .hs files in a dist directory inside the tarball. We don't 880-- use the standard 'dist' location so unless we move this dist dir to the 881-- right place then we'll miss the shipped pre-procssed files. This hacky 882-- approach to shipped pre-procssed files ought to be replaced by a proper 883-- system, though we'll still need to keep this hack for older packages. 884-- 885moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout 886 -> FilePath -> PackageId -> DistDirParams 887 -> IO () 888moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} 889 parentdir pkgid dparams = do 890 distDirExists <- doesDirectoryExist tarballDistDir 891 when distDirExists $ do 892 debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '" 893 ++ targetDistDir ++ "'" 894 --TODO: [nice to have] or perhaps better to copy, and use a file monitor 895 renameDirectory tarballDistDir targetDistDir 896 where 897 tarballDistDir = parentdir </> prettyShow pkgid </> "dist" 898 targetDistDir = distBuildDirectory dparams 899 900 901buildAndInstallUnpackedPackage :: Verbosity 902 -> DistDirLayout 903 -> StoreDirLayout 904 -> BuildTimeSettings -> Lock -> Lock 905 -> ElaboratedSharedConfig 906 -> ElaboratedInstallPlan 907 -> ElaboratedReadyPackage 908 -> FilePath -> FilePath 909 -> IO BuildResult 910buildAndInstallUnpackedPackage verbosity 911 distDirLayout@DistDirLayout{distTempDirectory} 912 storeDirLayout@StoreDirLayout { 913 storePackageDBStack 914 } 915 BuildTimeSettings { 916 buildSettingNumJobs, 917 buildSettingLogFile 918 } 919 registerLock cacheLock 920 pkgshared@ElaboratedSharedConfig { 921 pkgConfigPlatform = platform, 922 pkgConfigCompiler = compiler, 923 pkgConfigCompilerProgs = progdb 924 } 925 plan rpkg@(ReadyPackage pkg) 926 srcdir builddir = do 927 928 createDirectoryIfMissingVerbose verbosity True (srcdir </> builddir) 929 initLogFile 930 931 --TODO: [code cleanup] deal consistently with talking to older 932 -- Setup.hs versions, much like we do for ghc, with a proper 933 -- options type and rendering step which will also let us 934 -- call directly into the lib, rather than always going via 935 -- the lib's command line interface, which would also allow 936 -- passing data like installed packages, compiler, and 937 -- program db for a quicker configure. 938 939 --TODO: [required feature] docs and tests 940 --TODO: [required feature] sudo re-exec 941 942 -- Configure phase 943 noticeProgress ProgressStarting 944 945 annotateFailure mlogFile ConfigureFailed $ 946 setup' configureCommand configureFlags configureArgs 947 948 -- Build phase 949 noticeProgress ProgressBuilding 950 951 annotateFailure mlogFile BuildFailed $ 952 setup buildCommand buildFlags 953 954 -- Haddock phase 955 whenHaddock $ do 956 noticeProgress ProgressHaddock 957 annotateFailureNoLog HaddocksFailed $ 958 setup haddockCommand haddockFlags 959 960 -- Install phase 961 noticeProgress ProgressInstalling 962 annotateFailure mlogFile InstallFailed $ do 963 964 let copyPkgFiles tmpDir = do 965 let tmpDirNormalised = normalise tmpDir 966 setup Cabal.copyCommand (copyFlags tmpDirNormalised) 967 -- Note that the copy command has put the files into 968 -- @$tmpDir/$prefix@ so we need to return this dir so 969 -- the store knows which dir will be the final store entry. 970 let prefix = normalise $ 971 dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) 972 entryDir = tmpDirNormalised </> prefix 973 974 -- if there weren't anything to build, it might be that directory is not created 975 -- the @setup Cabal.copyCommand@ above might do nothing. 976 -- https://github.com/haskell/cabal/issues/4130 977 createDirectoryIfMissingVerbose verbosity True entryDir 978 979 LBS.writeFile 980 (entryDir </> "cabal-hash.txt") 981 (renderPackageHashInputs (packageHashInputs pkgshared pkg)) 982 983 -- Ensure that there are no files in `tmpDir`, that are 984 -- not in `entryDir`. While this breaks the 985 -- prefix-relocatable property of the libraries, it is 986 -- necessary on macOS to stay under the load command limit 987 -- of the macOS mach-o linker. See also 988 -- @PackageHash.hashedInstalledPackageIdVeryShort@. 989 -- 990 -- We also normalise paths to ensure that there are no 991 -- different representations for the same path. Like / and 992 -- \\ on windows under msys. 993 otherFiles <- filter (not . isPrefixOf entryDir) <$> 994 listFilesRecursive tmpDirNormalised 995 -- Here's where we could keep track of the installed files 996 -- ourselves if we wanted to by making a manifest of the 997 -- files in the tmp dir. 998 return (entryDir, otherFiles) 999 where 1000 listFilesRecursive :: FilePath -> IO [FilePath] 1001 listFilesRecursive path = do 1002 files <- fmap (path </>) <$> (listDirectory path) 1003 allFiles <- for files $ \file -> do 1004 isDir <- doesDirectoryExist file 1005 if isDir 1006 then listFilesRecursive file 1007 else return [file] 1008 return (concat allFiles) 1009 1010 registerPkg 1011 | not (elabRequiresRegistration pkg) = 1012 debug verbosity $ 1013 "registerPkg: elab does NOT require registration for " 1014 ++ prettyShow uid 1015 | otherwise = do 1016 -- We register ourselves rather than via Setup.hs. We need to 1017 -- grab and modify the InstalledPackageInfo. We decide what 1018 -- the installed package id is, not the build system. 1019 ipkg0 <- generateInstalledPackageInfo 1020 let ipkg = ipkg0 { Installed.installedUnitId = uid } 1021 assert ( elabRegisterPackageDBStack pkg 1022 == storePackageDBStack compid) (return ()) 1023 criticalSection registerLock $ 1024 Cabal.registerPackage 1025 verbosity compiler progdb 1026 (storePackageDBStack compid) ipkg 1027 Cabal.defaultRegisterOptions { 1028 Cabal.registerMultiInstance = True, 1029 Cabal.registerSuppressFilesCheck = True 1030 } 1031 1032 1033 -- Actual installation 1034 void $ newStoreEntry verbosity storeDirLayout 1035 compid uid 1036 copyPkgFiles registerPkg 1037 1038 --TODO: [nice to have] we currently rely on Setup.hs copy to do the right 1039 -- thing. Although we do copy into an image dir and do the move into the 1040 -- final location ourselves, perhaps we ought to do some sanity checks on 1041 -- the image dir first. 1042 1043 -- TODO: [required eventually] note that for nix-style 1044 -- installations it is not necessary to do the 1045 -- 'withWin32SelfUpgrade' dance, but it would be necessary for a 1046 -- shared bin dir. 1047 1048 --TODO: [required feature] docs and test phases 1049 let docsResult = DocsNotTried 1050 testsResult = TestsNotTried 1051 1052 noticeProgress ProgressCompleted 1053 1054 return BuildResult { 1055 buildResultDocs = docsResult, 1056 buildResultTests = testsResult, 1057 buildResultLogFile = mlogFile 1058 } 1059 1060 where 1061 pkgid = packageId rpkg 1062 uid = installedUnitId rpkg 1063 compid = compilerId compiler 1064 1065 dispname = case elabPkgOrComp pkg of 1066 ElabPackage _ -> prettyShow pkgid 1067 ++ " (all, legacy fallback)" 1068 ElabComponent comp -> prettyShow pkgid 1069 ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")" 1070 1071 noticeProgress phase = when isParallelBuild $ 1072 progressMessage verbosity phase dispname 1073 1074 isParallelBuild = buildSettingNumJobs >= 2 1075 1076 whenHaddock action 1077 | hasValidHaddockTargets pkg = action 1078 | otherwise = return () 1079 1080 configureCommand = Cabal.configureCommand defaultProgramDb 1081 configureFlags v = flip filterConfigureFlags v $ 1082 setupHsConfigureFlags rpkg pkgshared 1083 verbosity builddir 1084 configureArgs _ = setupHsConfigureArgs pkg 1085 1086 buildCommand = Cabal.buildCommand defaultProgramDb 1087 buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir 1088 1089 haddockCommand = Cabal.haddockCommand 1090 haddockFlags _ = setupHsHaddockFlags pkg pkgshared 1091 verbosity builddir 1092 1093 generateInstalledPackageInfo :: IO InstalledPackageInfo 1094 generateInstalledPackageInfo = 1095 withTempInstalledPackageInfoFile 1096 verbosity distTempDirectory $ \pkgConfDest -> do 1097 let registerFlags _ = setupHsRegisterFlags 1098 pkg pkgshared 1099 verbosity builddir 1100 pkgConfDest 1101 setup Cabal.registerCommand registerFlags 1102 1103 copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity 1104 builddir destdir 1105 1106 scriptOptions = setupHsScriptOptions rpkg plan pkgshared 1107 distDirLayout srcdir builddir 1108 isParallelBuild cacheLock 1109 1110 setup :: CommandUI flags -> (Version -> flags) -> IO () 1111 setup cmd flags = setup' cmd flags (const []) 1112 1113 setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) 1114 -> IO () 1115 setup' cmd flags args = 1116 withLogging $ \mLogFileHandle -> 1117 setupWrapper 1118 verbosity 1119 scriptOptions 1120 { useLoggingHandle = mLogFileHandle 1121 , useExtraEnvOverrides = dataDirsEnvironmentForPlan 1122 distDirLayout plan } 1123 (Just (elabPkgDescription pkg)) 1124 cmd flags args 1125 1126 mlogFile :: Maybe FilePath 1127 mlogFile = 1128 case buildSettingLogFile of 1129 Nothing -> Nothing 1130 Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) 1131 1132 initLogFile = 1133 case mlogFile of 1134 Nothing -> return () 1135 Just logFile -> do 1136 createDirectoryIfMissing True (takeDirectory logFile) 1137 exists <- doesFileExist logFile 1138 when exists $ removeFile logFile 1139 1140 withLogging action = 1141 case mlogFile of 1142 Nothing -> action Nothing 1143 Just logFile -> withFile logFile AppendMode (action . Just) 1144 1145 1146hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool 1147hasValidHaddockTargets ElaboratedConfiguredPackage{..} 1148 | not elabBuildHaddocks = False 1149 | otherwise = any componentHasHaddocks components 1150 where 1151 components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets 1152 ++ maybeToList elabReplTarget ++ elabHaddockTargets 1153 1154 componentHasHaddocks :: ComponentTarget -> Bool 1155 componentHasHaddocks (ComponentTarget name _) = 1156 case name of 1157 CLibName LMainLibName -> hasHaddocks 1158 CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks 1159 CFLibName _ -> elabHaddockForeignLibs && hasHaddocks 1160 CExeName _ -> elabHaddockExecutables && hasHaddocks 1161 CTestName _ -> elabHaddockTestSuites && hasHaddocks 1162 CBenchName _ -> elabHaddockBenchmarks && hasHaddocks 1163 where 1164 hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) 1165 1166 1167buildInplaceUnpackedPackage :: Verbosity 1168 -> DistDirLayout 1169 -> BuildTimeSettings -> Lock -> Lock 1170 -> ElaboratedSharedConfig 1171 -> ElaboratedInstallPlan 1172 -> ElaboratedReadyPackage 1173 -> BuildStatusRebuild 1174 -> FilePath -> FilePath 1175 -> IO BuildResult 1176buildInplaceUnpackedPackage verbosity 1177 distDirLayout@DistDirLayout { 1178 distTempDirectory, 1179 distPackageCacheDirectory, 1180 distDirectory 1181 } 1182 BuildTimeSettings{buildSettingNumJobs} 1183 registerLock cacheLock 1184 pkgshared@ElaboratedSharedConfig { 1185 pkgConfigCompiler = compiler, 1186 pkgConfigCompilerProgs = progdb 1187 } 1188 plan 1189 rpkg@(ReadyPackage pkg) 1190 buildStatus 1191 srcdir builddir = do 1192 1193 --TODO: [code cleanup] there is duplication between the 1194 -- distdirlayout and the builddir here builddir is not 1195 -- enough, we also need the per-package cachedir 1196 createDirectoryIfMissingVerbose verbosity True builddir 1197 createDirectoryIfMissingVerbose verbosity True 1198 (distPackageCacheDirectory dparams) 1199 1200 -- Configure phase 1201 -- 1202 whenReConfigure $ do 1203 annotateFailureNoLog ConfigureFailed $ 1204 setup configureCommand configureFlags configureArgs 1205 invalidatePackageRegFileMonitor packageFileMonitor 1206 updatePackageConfigFileMonitor packageFileMonitor srcdir pkg 1207 1208 -- Build phase 1209 -- 1210 let docsResult = DocsNotTried 1211 testsResult = TestsNotTried 1212 1213 buildResult :: BuildResultMisc 1214 buildResult = (docsResult, testsResult) 1215 1216 whenRebuild $ do 1217 timestamp <- beginUpdateFileMonitor 1218 annotateFailureNoLog BuildFailed $ 1219 setup buildCommand buildFlags buildArgs 1220 1221 let listSimple = 1222 execRebuild srcdir (needElaboratedConfiguredPackage pkg) 1223 listSdist = 1224 fmap (map monitorFileHashed) $ 1225 allPackageSourceFiles verbosity srcdir 1226 ifNullThen m m' = do xs <- m 1227 if null xs then m' else return xs 1228 monitors <- case PD.buildType (elabPkgDescription pkg) of 1229 Simple -> listSimple 1230 -- If a Custom setup was used, AND the Cabal is recent 1231 -- enough to have sdist --list-sources, use that to 1232 -- determine the files that we need to track. This can 1233 -- cause unnecessary rebuilding (for example, if README 1234 -- is edited, we will try to rebuild) but there isn't 1235 -- a more accurate Custom interface we can use to get 1236 -- this info. We prefer not to use listSimple here 1237 -- as it can miss extra source files that are considered 1238 -- by the Custom setup. 1239 _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17] 1240 -- However, sometimes sdist --list-sources will fail 1241 -- and return an empty list. In that case, fall 1242 -- back on the (inaccurate) simple tracking. 1243 -> listSdist `ifNullThen` listSimple 1244 | otherwise 1245 -> listSimple 1246 1247 let dep_monitors = map monitorFileHashed 1248 $ elabInplaceDependencyBuildCacheFiles 1249 distDirLayout pkgshared plan pkg 1250 updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp 1251 pkg buildStatus 1252 (monitors ++ dep_monitors) buildResult 1253 1254 -- PURPOSELY omitted: no copy! 1255 1256 whenReRegister $ annotateFailureNoLog InstallFailed $ do 1257 -- Register locally 1258 mipkg <- if elabRequiresRegistration pkg 1259 then do 1260 ipkg0 <- generateInstalledPackageInfo 1261 -- We register ourselves rather than via Setup.hs. We need to 1262 -- grab and modify the InstalledPackageInfo. We decide what 1263 -- the installed package id is, not the build system. 1264 let ipkg = ipkg0 { Installed.installedUnitId = ipkgid } 1265 criticalSection registerLock $ 1266 Cabal.registerPackage verbosity compiler progdb 1267 (elabRegisterPackageDBStack pkg) 1268 ipkg Cabal.defaultRegisterOptions 1269 return (Just ipkg) 1270 1271 else return Nothing 1272 1273 updatePackageRegFileMonitor packageFileMonitor srcdir mipkg 1274 1275 whenTest $ do 1276 annotateFailureNoLog TestsFailed $ 1277 setup testCommand testFlags testArgs 1278 1279 whenBench $ 1280 annotateFailureNoLog BenchFailed $ 1281 setup benchCommand benchFlags benchArgs 1282 1283 -- Repl phase 1284 -- 1285 whenRepl $ 1286 annotateFailureNoLog ReplFailed $ 1287 setupInteractive replCommand replFlags replArgs 1288 1289 -- Haddock phase 1290 whenHaddock $ 1291 annotateFailureNoLog HaddocksFailed $ do 1292 setup haddockCommand haddockFlags haddockArgs 1293 let haddockTarget = elabHaddockForHackage pkg 1294 when (haddockTarget == Cabal.ForHackage) $ do 1295 let dest = distDirectory </> name <.> "tar.gz" 1296 name = haddockDirName haddockTarget (elabPkgDescription pkg) 1297 docDir = distBuildDirectory distDirLayout dparams 1298 </> "doc" </> "html" 1299 Tar.createTarGzFile dest docDir name 1300 notice verbosity $ "Documentation tarball created: " ++ dest 1301 1302 return BuildResult { 1303 buildResultDocs = docsResult, 1304 buildResultTests = testsResult, 1305 buildResultLogFile = Nothing 1306 } 1307 1308 where 1309 ipkgid = installedUnitId pkg 1310 dparams = elabDistDirParams pkgshared pkg 1311 1312 isParallelBuild = buildSettingNumJobs >= 2 1313 1314 packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams 1315 1316 whenReConfigure action = case buildStatus of 1317 BuildStatusConfigure _ -> action 1318 _ -> return () 1319 1320 whenRebuild action 1321 | null (elabBuildTargets pkg) 1322 -- NB: we have to build the test/bench suite! 1323 , null (elabTestTargets pkg) 1324 , null (elabBenchTargets pkg) = return () 1325 | otherwise = action 1326 1327 whenTest action 1328 | null (elabTestTargets pkg) = return () 1329 | otherwise = action 1330 1331 whenBench action 1332 | null (elabBenchTargets pkg) = return () 1333 | otherwise = action 1334 1335 whenRepl action 1336 | isNothing (elabReplTarget pkg) = return () 1337 | otherwise = action 1338 1339 whenHaddock action 1340 | hasValidHaddockTargets pkg = action 1341 | otherwise = return () 1342 1343 whenReRegister action 1344 = case buildStatus of 1345 -- We registered the package already 1346 BuildStatusBuild (Just _) _ -> 1347 info verbosity "whenReRegister: previously registered" 1348 -- There is nothing to register 1349 _ | null (elabBuildTargets pkg) -> 1350 info verbosity "whenReRegister: nothing to register" 1351 | otherwise -> action 1352 1353 configureCommand = Cabal.configureCommand defaultProgramDb 1354 configureFlags v = flip filterConfigureFlags v $ 1355 setupHsConfigureFlags rpkg pkgshared 1356 verbosity builddir 1357 configureArgs _ = setupHsConfigureArgs pkg 1358 1359 buildCommand = Cabal.buildCommand defaultProgramDb 1360 buildFlags _ = setupHsBuildFlags pkg pkgshared 1361 verbosity builddir 1362 buildArgs _ = setupHsBuildArgs pkg 1363 1364 testCommand = Cabal.testCommand -- defaultProgramDb 1365 testFlags v = flip filterTestFlags v $ 1366 setupHsTestFlags pkg pkgshared 1367 verbosity builddir 1368 testArgs _ = setupHsTestArgs pkg 1369 1370 benchCommand = Cabal.benchmarkCommand 1371 benchFlags _ = setupHsBenchFlags pkg pkgshared 1372 verbosity builddir 1373 benchArgs _ = setupHsBenchArgs pkg 1374 1375 replCommand = Cabal.replCommand defaultProgramDb 1376 replFlags _ = setupHsReplFlags pkg pkgshared 1377 verbosity builddir 1378 replArgs _ = setupHsReplArgs pkg 1379 1380 haddockCommand = Cabal.haddockCommand 1381 haddockFlags v = flip filterHaddockFlags v $ 1382 setupHsHaddockFlags pkg pkgshared 1383 verbosity builddir 1384 haddockArgs v = flip filterHaddockArgs v $ 1385 setupHsHaddockArgs pkg 1386 1387 scriptOptions = setupHsScriptOptions rpkg plan pkgshared 1388 distDirLayout srcdir builddir 1389 isParallelBuild cacheLock 1390 1391 setupInteractive :: CommandUI flags 1392 -> (Version -> flags) -> (Version -> [String]) -> IO () 1393 setupInteractive cmd flags args = 1394 setupWrapper verbosity 1395 scriptOptions { isInteractive = True } 1396 (Just (elabPkgDescription pkg)) 1397 cmd flags args 1398 1399 setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) 1400 -> IO () 1401 setup cmd flags args = 1402 setupWrapper verbosity 1403 scriptOptions 1404 (Just (elabPkgDescription pkg)) 1405 cmd flags args 1406 1407 generateInstalledPackageInfo :: IO InstalledPackageInfo 1408 generateInstalledPackageInfo = 1409 withTempInstalledPackageInfoFile 1410 verbosity distTempDirectory $ \pkgConfDest -> do 1411 let registerFlags _ = setupHsRegisterFlags 1412 pkg pkgshared 1413 verbosity builddir 1414 pkgConfDest 1415 setup Cabal.registerCommand registerFlags (const []) 1416 1417withTempInstalledPackageInfoFile :: Verbosity -> FilePath 1418 -> (FilePath -> IO ()) 1419 -> IO InstalledPackageInfo 1420withTempInstalledPackageInfoFile verbosity tempdir action = 1421 withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do 1422 -- make absolute since @action@ will often change directory 1423 abs_dir <- canonicalizePath dir 1424 1425 let pkgConfDest = abs_dir </> "pkgConf" 1426 action pkgConfDest 1427 1428 readPkgConf "." pkgConfDest 1429 where 1430 pkgConfParseFailed :: String -> IO a 1431 pkgConfParseFailed perror = 1432 die' verbosity $ 1433 "Couldn't parse the output of 'setup register --gen-pkg-config':" 1434 ++ show perror 1435 1436 readPkgConf pkgConfDir pkgConfFile = do 1437 pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile) 1438 (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of 1439 Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors 1440 Right (warns, ipkg) -> return (warns, ipkg) 1441 1442 unless (null warns) $ 1443 warn verbosity $ unlines warns 1444 1445 return ipkg 1446 1447 1448------------------------------------------------------------------------------ 1449-- * Utilities 1450------------------------------------------------------------------------------ 1451 1452annotateFailureNoLog :: (SomeException -> BuildFailureReason) 1453 -> IO a -> IO a 1454annotateFailureNoLog annotate action = 1455 annotateFailure Nothing annotate action 1456 1457annotateFailure :: Maybe FilePath 1458 -> (SomeException -> BuildFailureReason) 1459 -> IO a -> IO a 1460annotateFailure mlogFile annotate action = 1461 action `catches` 1462 -- It's not just IOException and ExitCode we have to deal with, there's 1463 -- lots, including exceptions from the hackage-security and tar packages. 1464 -- So we take the strategy of catching everything except async exceptions. 1465 [ 1466#if MIN_VERSION_base(4,7,0) 1467 Handler $ \async -> throwIO (async :: SomeAsyncException) 1468#else 1469 Handler $ \async -> throwIO (async :: AsyncException) 1470#endif 1471 , Handler $ \other -> handler (other :: SomeException) 1472 ] 1473 where 1474 handler :: Exception e => e -> IO a 1475 handler = throwIO . BuildFailure mlogFile . annotate . toException 1476