1{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns, 2 DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving, 3 ScopedTypeVariables #-} 4 5module Distribution.Client.ProjectPlanOutput ( 6 -- * Plan output 7 writePlanExternalRepresentation, 8 9 -- * Project status 10 -- | Several outputs rely on having a general overview of 11 PostBuildProjectStatus(..), 12 updatePostBuildProjectStatus, 13 createPackageEnvironment, 14 writePlanGhcEnvironment, 15 argsEquivalentOfGhcEnvironmentFile, 16 ) where 17 18import Distribution.Client.ProjectPlanning.Types 19import Distribution.Client.ProjectBuilding.Types 20import Distribution.Client.DistDirLayout 21import Distribution.Client.Types (Repo(..), RemoteRepo(..), PackageLocation(..), confInstId) 22import Distribution.Client.HashValue (showHashValue, hashValue) 23import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) 24 25import qualified Distribution.Client.InstallPlan as InstallPlan 26import qualified Distribution.Client.Utils.Json as J 27import qualified Distribution.Simple.InstallDirs as InstallDirs 28 29import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps 30 31import Distribution.Package 32import Distribution.System 33import Distribution.InstalledPackageInfo (InstalledPackageInfo) 34import qualified Distribution.PackageDescription as PD 35import Distribution.Compiler (CompilerFlavor(GHC, GHCJS)) 36import Distribution.Simple.Compiler 37 ( PackageDBStack, PackageDB(..) 38 , compilerVersion, compilerFlavor, showCompilerId 39 , compilerId, CompilerId(..), Compiler ) 40import Distribution.Simple.GHC 41 ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) 42 , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile 43 , writeGhcEnvironmentFile ) 44import Distribution.Deprecated.Text 45import qualified Distribution.Compat.Graph as Graph 46import Distribution.Compat.Graph (Graph, Node) 47import qualified Distribution.Compat.Binary as Binary 48import Distribution.Simple.Utils 49import Distribution.Verbosity 50import qualified Paths_cabal_install as Our (version) 51 52import Prelude () 53import Distribution.Client.Compat.Prelude 54 55import qualified Data.Map as Map 56import qualified Data.Set as Set 57import qualified Data.ByteString.Lazy as BS 58import qualified Data.ByteString.Builder as BB 59 60import System.FilePath 61import System.IO 62 63import Distribution.Simple.Program.GHC (packageDbArgsDb) 64 65----------------------------------------------------------------------------- 66-- Writing plan.json files 67-- 68 69-- | Write out a representation of the elaborated install plan. 70-- 71-- This is for the benefit of debugging and external tools like editors. 72-- 73writePlanExternalRepresentation :: DistDirLayout 74 -> ElaboratedInstallPlan 75 -> ElaboratedSharedConfig 76 -> IO () 77writePlanExternalRepresentation distDirLayout elaboratedInstallPlan 78 elaboratedSharedConfig = 79 writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $ 80 BB.toLazyByteString 81 . J.encodeToBuilder 82 $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig 83 84-- | Renders a subset of the elaborated install plan in a semi-stable JSON 85-- format. 86-- 87encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value 88encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = 89 --TODO: [nice to have] include all of the sharedPackageConfig and all of 90 -- the parts of the elaboratedInstallPlan 91 J.object [ "cabal-version" J..= jdisplay Our.version 92 , "cabal-lib-version" J..= jdisplay cabalVersion 93 , "compiler-id" J..= (J.String . showCompilerId . pkgConfigCompiler) 94 elaboratedSharedConfig 95 , "os" J..= jdisplay os 96 , "arch" J..= jdisplay arch 97 , "install-plan" J..= installPlanToJ elaboratedInstallPlan 98 ] 99 where 100 Platform arch os = pkgConfigPlatform elaboratedSharedConfig 101 102 installPlanToJ :: ElaboratedInstallPlan -> [J.Value] 103 installPlanToJ = map planPackageToJ . InstallPlan.toList 104 105 planPackageToJ :: ElaboratedPlanPackage -> J.Value 106 planPackageToJ pkg = 107 case pkg of 108 InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi 109 InstallPlan.Configured elab -> elaboratedPackageToJ False elab 110 InstallPlan.Installed elab -> elaboratedPackageToJ True elab 111 -- Note that the plan.json currently only uses the elaborated plan, 112 -- not the improved plan. So we will not get the Installed state for 113 -- that case, but the code supports it in case we want to use this 114 -- later in some use case where we want the status of the build. 115 116 installedPackageInfoToJ :: InstalledPackageInfo -> J.Value 117 installedPackageInfoToJ ipi = 118 -- Pre-existing packages lack configuration information such as their flag 119 -- settings or non-lib components. We only get pre-existing packages for 120 -- the global/core packages however, so this isn't generally a problem. 121 -- So these packages are never local to the project. 122 -- 123 J.object 124 [ "type" J..= J.String "pre-existing" 125 , "id" J..= (jdisplay . installedUnitId) ipi 126 , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi 127 , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi 128 , "depends" J..= map jdisplay (installedDepends ipi) 129 ] 130 131 elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value 132 elaboratedPackageToJ isInstalled elab = 133 J.object $ 134 [ "type" J..= J.String (if isInstalled then "installed" 135 else "configured") 136 , "id" J..= (jdisplay . installedUnitId) elab 137 , "pkg-name" J..= (jdisplay . pkgName . packageId) elab 138 , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab 139 , "flags" J..= J.object [ PD.unFlagName fn J..= v 140 | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] 141 , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) 142 , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) 143 ] ++ 144 [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) 145 | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] ++ 146 [ "pkg-src-sha256" J..= J.String (showHashValue hash) 147 | Just hash <- [elabPkgSourceHash elab] ] ++ 148 (case elabBuildStyle elab of 149 BuildInplaceOnly -> 150 ["dist-dir" J..= J.String dist_dir] 151 BuildAndInstall -> 152 -- TODO: install dirs? 153 [] 154 ) ++ 155 case elabPkgOrComp elab of 156 ElabPackage pkg -> 157 let components = J.object $ 158 [ comp2str c J..= (J.object $ 159 [ "depends" J..= map (jdisplay . confInstId) ldeps 160 , "exe-depends" J..= map (jdisplay . confInstId) edeps 161 ] ++ 162 bin_file c) 163 | (c,(ldeps,edeps)) 164 <- ComponentDeps.toList $ 165 ComponentDeps.zip (pkgLibDependencies pkg) 166 (pkgExeDependencies pkg) ] 167 in ["components" J..= components] 168 ElabComponent comp -> 169 ["depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab) 170 ,"exe-depends" J..= map jdisplay (elabExeDependencies elab) 171 ,"component-name" J..= J.String (comp2str (compSolverName comp)) 172 ] ++ 173 bin_file (compSolverName comp) 174 where 175 packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value 176 packageLocationToJ pkgloc = 177 case pkgloc of 178 LocalUnpackedPackage local -> 179 J.object [ "type" J..= J.String "local" 180 , "path" J..= J.String local 181 ] 182 LocalTarballPackage local -> 183 J.object [ "type" J..= J.String "local-tar" 184 , "path" J..= J.String local 185 ] 186 RemoteTarballPackage uri _ -> 187 J.object [ "type" J..= J.String "remote-tar" 188 , "uri" J..= J.String (show uri) 189 ] 190 RepoTarballPackage repo _ _ -> 191 J.object [ "type" J..= J.String "repo-tar" 192 , "repo" J..= repoToJ repo 193 ] 194 RemoteSourceRepoPackage srcRepo _ -> 195 J.object [ "type" J..= J.String "source-repo" 196 , "source-repo" J..= sourceRepoToJ srcRepo 197 ] 198 199 repoToJ :: Repo -> J.Value 200 repoToJ repo = 201 case repo of 202 RepoLocal{..} -> 203 J.object [ "type" J..= J.String "local-repo" 204 , "path" J..= J.String repoLocalDir 205 ] 206 RepoLocalNoIndex{..} -> 207 J.object [ "type" J..= J.String "local-repo-no-index" 208 , "path" J..= J.String repoLocalDir 209 ] 210 RepoRemote{..} -> 211 J.object [ "type" J..= J.String "remote-repo" 212 , "uri" J..= J.String (show (remoteRepoURI repoRemote)) 213 ] 214 RepoSecure{..} -> 215 J.object [ "type" J..= J.String "secure-repo" 216 , "uri" J..= J.String (show (remoteRepoURI repoRemote)) 217 ] 218 219 sourceRepoToJ :: SourceRepoMaybe -> J.Value 220 sourceRepoToJ SourceRepositoryPackage{..} = 221 J.object $ filter ((/= J.Null) . snd) $ 222 [ "type" J..= jdisplay srpType 223 , "location" J..= J.String srpLocation 224 , "branch" J..= fmap J.String srpBranch 225 , "tag" J..= fmap J.String srpTag 226 , "subdir" J..= fmap J.String srpSubdir 227 ] 228 229 dist_dir = distBuildDirectory distDirLayout 230 (elabDistDirParams elaboratedSharedConfig elab) 231 232 bin_file c = case c of 233 ComponentDeps.ComponentExe s -> bin_file' s 234 ComponentDeps.ComponentTest s -> bin_file' s 235 ComponentDeps.ComponentBench s -> bin_file' s 236 _ -> [] 237 bin_file' s = 238 ["bin-file" J..= J.String bin] 239 where 240 bin = if elabBuildStyle elab == BuildInplaceOnly 241 then dist_dir </> "build" </> display s </> display s 242 else InstallDirs.bindir (elabInstallDirs elab) </> display s 243 244 -- TODO: maybe move this helper to "ComponentDeps" module? 245 -- Or maybe define a 'Text' instance? 246 comp2str :: ComponentDeps.Component -> String 247 comp2str c = case c of 248 ComponentDeps.ComponentLib -> "lib" 249 ComponentDeps.ComponentSubLib s -> "lib:" <> display s 250 ComponentDeps.ComponentFLib s -> "flib:" <> display s 251 ComponentDeps.ComponentExe s -> "exe:" <> display s 252 ComponentDeps.ComponentTest s -> "test:" <> display s 253 ComponentDeps.ComponentBench s -> "bench:" <> display s 254 ComponentDeps.ComponentSetup -> "setup" 255 256 style2str :: Bool -> BuildStyle -> String 257 style2str True _ = "local" 258 style2str False BuildInplaceOnly = "inplace" 259 style2str False BuildAndInstall = "global" 260 261 jdisplay :: Text a => a -> J.Value 262 jdisplay = J.String . display 263 264 265----------------------------------------------------------------------------- 266-- Project status 267-- 268 269-- So, what is the status of a project after a build? That is, how do the 270-- inputs (package source files etc) compare to the output artefacts (build 271-- libs, exes etc)? Do the outputs reflect the current values of the inputs 272-- or are outputs out of date or invalid? 273-- 274-- First of all, what do we mean by out-of-date and what do we mean by 275-- invalid? We think of the build system as a morally pure function that 276-- computes the output artefacts given input values. We say an output artefact 277-- is out of date when its value is not the value that would be computed by a 278-- build given the current values of the inputs. An output artefact can be 279-- out-of-date but still be perfectly usable; it simply correspond to a 280-- previous state of the inputs. 281-- 282-- On the other hand there are cases where output artefacts cannot safely be 283-- used. For example libraries and dynamically linked executables cannot be 284-- used when the libs they depend on change without them being recompiled 285-- themselves. Whether an artefact is still usable depends on what it is, e.g. 286-- dynamically linked vs statically linked and on how it gets updated (e.g. 287-- only atomically on success or if failure can leave invalid states). We need 288-- a definition (or two) that is independent of the kind of artefact and can 289-- be computed just in terms of changes in package graphs, but are still 290-- useful for determining when particular kinds of artefacts are invalid. 291-- 292-- Note that when we talk about packages in this context we just mean nodes 293-- in the elaborated install plan, which can be components or packages. 294-- 295-- There's obviously a close connection between packages being out of date and 296-- their output artefacts being unusable: most of the time if a package 297-- remains out of date at the end of a build then some of its output artefacts 298-- will be unusable. That is true most of the time because a build will have 299-- attempted to build one of the out-of-date package's dependencies. If the 300-- build of the dependency succeeded then it changed output artefacts (like 301-- libs) and if it failed then it may have failed after already changing 302-- things (think failure after updating some but not all .hi files). 303-- 304-- There are a few reasons we may end up with still-usable output artefacts 305-- for a package even when it remains out of date at the end of a build. 306-- Firstly if executing a plan fails then packages can be skipped, and thus we 307-- may have packages where all their dependencies were skipped. Secondly we 308-- have artefacts like statically linked executables which are not affected by 309-- libs they depend on being recompiled. Furthermore, packages can be out of 310-- date due to changes in build tools or Setup.hs scripts they depend on, but 311-- again libraries or executables in those out-of-date packages remain usable. 312-- 313-- So we have two useful definitions of invalid. Both are useful, for 314-- different purposes, so we will compute both. The first corresponds to the 315-- invalid libraries and dynamic executables. We say a package is invalid by 316-- changed deps if any of the packages it depends on (via library dep edges) 317-- were rebuilt (successfully or unsuccessfully). The second definition 318-- corresponds to invalid static executables. We say a package is invalid by 319-- a failed build simply if the package was built but unsuccessfully. 320-- 321-- So how do we find out what packages are out of date or invalid? 322-- 323-- Obviously we know something for all the packages that were part of the plan 324-- that was executed, but that is just a subset since we prune the plan down 325-- to the targets and their dependencies. 326-- 327-- Recall the steps we go though: 328-- 329-- + starting with the initial improved plan (this is the full project); 330-- 331-- + prune the plan to the user's build targets; 332-- 333-- + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap 334-- covering the pruned subset of the original plan; 335-- 336-- + execute the plan giving us BuildOutcomes which tell us success/failure 337-- for each package. 338-- 339-- So given that the BuildStatusMap and BuildOutcomes do not cover everything 340-- in the original plan, what can they tell us about the original plan? 341-- 342-- The BuildStatusMap tells us directly that some packages are up to date and 343-- others out of date (but only for the pruned subset). But we know that 344-- everything that is a reverse dependency of an out-of-date package is itself 345-- out-of-date (whether or not it is in the pruned subset). Of course after 346-- a build the BuildOutcomes may tell us that some of those out-of-date 347-- packages are now up to date (ie a successful build outcome). 348-- 349-- The difference is packages that are reverse dependencies of out-of-date 350-- packages but are not brought up-to-date by the build (i.e. did not have 351-- successful outcomes, either because they failed or were not in the pruned 352-- subset to be built). We also know which packages were rebuilt, so we can 353-- use this to find the now-invalid packages. 354-- 355-- Note that there are still packages for which we cannot discover full status 356-- information. There may be packages outside of the pruned plan that do not 357-- depend on packages within the pruned plan that were discovered to be 358-- out-of-date. For these packages we do not know if their build artefacts 359-- are out-of-date or not. We do know however that they are not invalid, as 360-- that's not possible given our definition of invalid. Intuitively it is 361-- because we have not disturbed anything that these packages depend on, e.g. 362-- we've not rebuilt any libs they depend on. Recall that our widest 363-- definition of invalid was only concerned about dependencies on libraries 364-- (to cover problems like shared libs or GHC seeing inconsistent .hi files). 365-- 366-- So our algorithm for out-of-date packages is relatively simple: take the 367-- reverse dependency closure in the original improved plan (pre-pruning) of 368-- the out-of-date packages (as determined by the BuildStatusMap from the dry 369-- run). That gives a set of packages that were definitely out of date after 370-- the dry run. Now we remove from this set the packages that the 371-- BuildOutcomes tells us are now up-to-date after the build. The remaining 372-- set is the out-of-date packages. 373-- 374-- As for packages that are invalid by changed deps, we start with the plan 375-- dependency graph but keep only those edges that point to libraries (so 376-- ignoring deps on exes and setup scripts). We take the packages for which a 377-- build was attempted (successfully or unsuccessfully, but not counting 378-- knock-on failures) and take the reverse dependency closure. We delete from 379-- this set all the packages that were built successfully. Note that we do not 380-- need to intersect with the out-of-date packages since this follows 381-- automatically: all rev deps of packages we attempted to build must have 382-- been out of date at the start of the build, and if they were not built 383-- successfully then they're still out of date -- meeting our definition of 384-- invalid. 385 386 387type PackageIdSet = Set UnitId 388type PackagesUpToDate = PackageIdSet 389 390data PostBuildProjectStatus = PostBuildProjectStatus { 391 392 -- | Packages that are known to be up to date. These were found to be 393 -- up to date before the build, or they have a successful build outcome 394 -- afterwards. 395 -- 396 -- This does not include any packages outside of the subset of the plan 397 -- that was executed because we did not check those and so don't know 398 -- for sure that they're still up to date. 399 -- 400 packagesDefinitelyUpToDate :: PackageIdSet, 401 402 -- | Packages that are probably still up to date (and at least not 403 -- known to be out of date, and certainly not invalid). This includes 404 -- 'packagesDefinitelyUpToDate' plus packages that were up to date 405 -- previously and are outside of the subset of the plan that was 406 -- executed. It excludes 'packagesOutOfDate'. 407 -- 408 packagesProbablyUpToDate :: PackageIdSet, 409 410 -- | Packages that are known to be out of date. These are packages 411 -- that were determined to be out of date before the build, and they 412 -- do not have a successful build outcome afterwards. 413 -- 414 -- Note that this can sometimes include packages outside of the subset 415 -- of the plan that was executed. For example suppose package A and B 416 -- depend on C, and A is the target so only A and C are in the subset 417 -- to be built. Now suppose C is found to have changed, then both A 418 -- and B are out-of-date before the build and since B is outside the 419 -- subset to be built then it will remain out of date. 420 -- 421 -- Note also that this is /not/ the inverse of 422 -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'. 423 -- There are packages where we have no information (ones that were not 424 -- in the subset of the plan that was executed). 425 -- 426 packagesOutOfDate :: PackageIdSet, 427 428 -- | Packages that depend on libraries that have changed during the 429 -- build (either build success or failure). 430 -- 431 -- This corresponds to the fact that libraries and dynamic executables 432 -- are invalid once any of the libs they depend on change. 433 -- 434 -- This does include packages that themselves failed (i.e. it is a 435 -- superset of 'packagesInvalidByFailedBuild'). It does not include 436 -- changes in dependencies on executables (i.e. build tools). 437 -- 438 packagesInvalidByChangedLibDeps :: PackageIdSet, 439 440 -- | Packages that themselves failed during the build (i.e. them 441 -- directly not a dep). 442 -- 443 -- This corresponds to the fact that static executables are invalid 444 -- in unlucky circumstances such as linking failing half way though, 445 -- or data file generation failing. 446 -- 447 -- This is a subset of 'packagesInvalidByChangedLibDeps'. 448 -- 449 packagesInvalidByFailedBuild :: PackageIdSet, 450 451 -- | A subset of the plan graph, including only dependency-on-library 452 -- edges. That is, dependencies /on/ libraries, not dependencies /of/ 453 -- libraries. This tells us all the libraries that packages link to. 454 -- 455 -- This is here as a convenience, as strictly speaking it's not status 456 -- as it's just a function of the original 'ElaboratedInstallPlan'. 457 -- 458 packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage), 459 460 -- | As a convenience for 'Set.intersection' with any of the other 461 -- 'PackageIdSet's to select only packages that are part of the 462 -- project locally (i.e. with a local source dir). 463 -- 464 packagesBuildLocal :: PackageIdSet, 465 466 -- | As a convenience for 'Set.intersection' with any of the other 467 -- 'PackageIdSet's to select only packages that are being built 468 -- in-place within the project (i.e. not destined for the store). 469 -- 470 packagesBuildInplace :: PackageIdSet, 471 472 -- | As a convenience for 'Set.intersection' or 'Set.difference' with 473 -- any of the other 'PackageIdSet's to select only packages that were 474 -- pre-installed or already in the store prior to the build. 475 -- 476 packagesAlreadyInStore :: PackageIdSet 477 } 478 479-- | Work out which packages are out of date or invalid after a build. 480-- 481postBuildProjectStatus :: ElaboratedInstallPlan 482 -> PackagesUpToDate 483 -> BuildStatusMap 484 -> BuildOutcomes 485 -> PostBuildProjectStatus 486postBuildProjectStatus plan previousPackagesUpToDate 487 pkgBuildStatus buildOutcomes = 488 PostBuildProjectStatus { 489 packagesDefinitelyUpToDate, 490 packagesProbablyUpToDate, 491 packagesOutOfDate, 492 packagesInvalidByChangedLibDeps, 493 packagesInvalidByFailedBuild, 494 -- convenience stuff 495 packagesLibDepGraph, 496 packagesBuildLocal, 497 packagesBuildInplace, 498 packagesAlreadyInStore 499 } 500 where 501 packagesDefinitelyUpToDate = 502 packagesUpToDatePreBuild 503 `Set.union` 504 packagesSuccessfulPostBuild 505 506 packagesProbablyUpToDate = 507 packagesDefinitelyUpToDate 508 `Set.union` 509 (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild) 510 511 packagesOutOfDate = 512 packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild 513 514 packagesInvalidByChangedLibDeps = 515 packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild 516 517 packagesInvalidByFailedBuild = 518 packagesFailurePostBuild 519 520 -- Note: if any of the intermediate values below turn out to be useful in 521 -- their own right then we can simply promote them to the result record 522 523 -- The previous set of up-to-date packages will contain bogus package ids 524 -- when the solver plan or config contributing to the hash changes. 525 -- So keep only the ones where the package id (i.e. hash) is the same. 526 previousPackagesUpToDate' = 527 Set.intersection 528 previousPackagesUpToDate 529 (InstallPlan.keysSet plan) 530 531 packagesUpToDatePreBuild = 532 Set.filter 533 (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid)) 534 -- For packages not in the plan subset we did the dry-run on we don't 535 -- know anything about their status, so not known to be /up to date/. 536 (InstallPlan.keysSet plan) 537 538 packagesOutOfDatePreBuild = 539 Set.fromList . map installedUnitId $ 540 InstallPlan.reverseDependencyClosure plan 541 [ ipkgid 542 | pkg <- InstallPlan.toList plan 543 , let ipkgid = installedUnitId pkg 544 , lookupBuildStatusRequiresBuild False ipkgid 545 -- For packages not in the plan subset we did the dry-run on we don't 546 -- know anything about their status, so not known to be /out of date/. 547 ] 548 549 packagesSuccessfulPostBuild = 550 Set.fromList 551 [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ] 552 553 -- direct failures, not failures due to deps 554 packagesFailurePostBuild = 555 Set.fromList 556 [ ikgid 557 | (ikgid, Left failure) <- Map.toList buildOutcomes 558 , case buildFailureReason failure of 559 DependentFailed _ -> False 560 _ -> True 561 ] 562 563 -- Packages that have a library dependency on a package for which a build 564 -- was attempted 565 packagesDepOnChangedLib = 566 Set.fromList . map Graph.nodeKey $ 567 fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ 568 Graph.revClosure packagesLibDepGraph 569 ( Map.keys 570 . Map.filter (uncurry buildAttempted) 571 $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes 572 ) 573 574 -- The plan graph but only counting dependency-on-library edges 575 packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) 576 packagesLibDepGraph = 577 Graph.fromDistinctList 578 [ Graph.N pkg (installedUnitId pkg) libdeps 579 | pkg <- InstallPlan.toList plan 580 , let libdeps = case pkg of 581 InstallPlan.PreExisting ipkg -> installedDepends ipkg 582 InstallPlan.Configured srcpkg -> elabLibDeps srcpkg 583 InstallPlan.Installed srcpkg -> elabLibDeps srcpkg 584 ] 585 elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies 586 587 -- Was a build was attempted for this package? 588 -- If it doesn't have both a build status and outcome then the answer is no. 589 buildAttempted :: BuildStatus -> BuildOutcome -> Bool 590 -- And not if it didn't need rebuilding in the first place. 591 buildAttempted buildStatus _buildOutcome 592 | not (buildStatusRequiresBuild buildStatus) 593 = False 594 595 -- And not if it was skipped due to a dep failing first. 596 buildAttempted _ (Left BuildFailure {buildFailureReason}) 597 | DependentFailed _ <- buildFailureReason 598 = False 599 600 -- Otherwise, succeeded or failed, yes the build was tried. 601 buildAttempted _ (Left BuildFailure {}) = True 602 buildAttempted _ (Right _) = True 603 604 lookupBuildStatusRequiresBuild def ipkgid = 605 case Map.lookup ipkgid pkgBuildStatus of 606 Nothing -> def -- Not in the plan subset we did the dry-run on 607 Just buildStatus -> buildStatusRequiresBuild buildStatus 608 609 packagesBuildLocal = 610 selectPlanPackageIdSet $ \pkg -> 611 case pkg of 612 InstallPlan.PreExisting _ -> False 613 InstallPlan.Installed _ -> False 614 InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg 615 616 packagesBuildInplace = 617 selectPlanPackageIdSet $ \pkg -> 618 case pkg of 619 InstallPlan.PreExisting _ -> False 620 InstallPlan.Installed _ -> False 621 InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg 622 == BuildInplaceOnly 623 624 packagesAlreadyInStore = 625 selectPlanPackageIdSet $ \pkg -> 626 case pkg of 627 InstallPlan.PreExisting _ -> True 628 InstallPlan.Installed _ -> True 629 InstallPlan.Configured _ -> False 630 631 selectPlanPackageIdSet p = Map.keysSet 632 . Map.filter p 633 $ InstallPlan.toMap plan 634 635 636 637updatePostBuildProjectStatus :: Verbosity 638 -> DistDirLayout 639 -> ElaboratedInstallPlan 640 -> BuildStatusMap 641 -> BuildOutcomes 642 -> IO PostBuildProjectStatus 643updatePostBuildProjectStatus verbosity distDirLayout 644 elaboratedInstallPlan 645 pkgsBuildStatus buildOutcomes = do 646 647 -- Read the previous up-to-date set, update it and write it back 648 previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout 649 let currentBuildStatus@PostBuildProjectStatus{..} 650 = postBuildProjectStatus 651 elaboratedInstallPlan 652 previousUpToDate 653 pkgsBuildStatus 654 buildOutcomes 655 let currentUpToDate = packagesProbablyUpToDate 656 writePackagesUpToDateCacheFile distDirLayout currentUpToDate 657 658 -- Report various possibly interesting things 659 -- We additionally intersect with the packagesBuildInplace so that 660 -- we don't show huge numbers of boring packages from the store. 661 debugNoWrap verbosity $ 662 "packages definitely up to date: " 663 ++ displayPackageIdSet (packagesDefinitelyUpToDate 664 `Set.intersection` packagesBuildInplace) 665 666 debugNoWrap verbosity $ 667 "packages previously probably up to date: " 668 ++ displayPackageIdSet (previousUpToDate 669 `Set.intersection` packagesBuildInplace) 670 671 debugNoWrap verbosity $ 672 "packages now probably up to date: " 673 ++ displayPackageIdSet (packagesProbablyUpToDate 674 `Set.intersection` packagesBuildInplace) 675 676 debugNoWrap verbosity $ 677 "packages newly up to date: " 678 ++ displayPackageIdSet (packagesDefinitelyUpToDate 679 `Set.difference` previousUpToDate 680 `Set.intersection` packagesBuildInplace) 681 682 debugNoWrap verbosity $ 683 "packages out to date: " 684 ++ displayPackageIdSet (packagesOutOfDate 685 `Set.intersection` packagesBuildInplace) 686 687 debugNoWrap verbosity $ 688 "packages invalid due to dep change: " 689 ++ displayPackageIdSet packagesInvalidByChangedLibDeps 690 691 debugNoWrap verbosity $ 692 "packages invalid due to build failure: " 693 ++ displayPackageIdSet packagesInvalidByFailedBuild 694 695 return currentBuildStatus 696 where 697 displayPackageIdSet = intercalate ", " . map display . Set.toList 698 699-- | Helper for reading the cache file. 700-- 701-- This determines the type and format of the binary cache file. 702-- 703readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate 704readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} = 705 handleDoesNotExist Set.empty $ 706 handleDecodeFailure $ 707 withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd -> 708 Binary.decodeOrFailIO =<< BS.hGetContents hnd 709 where 710 handleDecodeFailure = fmap (either (const Set.empty) id) 711 712-- | Helper for writing the package up-to-date cache file. 713-- 714-- This determines the type and format of the binary cache file. 715-- 716writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO () 717writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate = 718 writeFileAtomic (distProjectCacheFile "up-to-date") $ 719 Binary.encode upToDate 720 721-- | Prepare a package environment that includes all the library dependencies 722-- for a plan. 723-- 724-- When running cabal new-exec, we want to set things up so that the compiler 725-- can find all the right packages (and nothing else). This function is 726-- intended to do that work. It takes a location where it can write files 727-- temporarily, in case the compiler wants to learn this information via the 728-- filesystem, and returns any environment variable overrides the compiler 729-- needs. 730createPackageEnvironment :: Verbosity 731 -> FilePath 732 -> ElaboratedInstallPlan 733 -> ElaboratedSharedConfig 734 -> PostBuildProjectStatus 735 -> IO [(String, Maybe String)] 736createPackageEnvironment verbosity 737 path 738 elaboratedPlan 739 elaboratedShared 740 buildStatus 741 | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC 742 = do 743 envFileM <- writePlanGhcEnvironment 744 path 745 elaboratedPlan 746 elaboratedShared 747 buildStatus 748 case envFileM of 749 Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)] 750 Nothing -> do 751 warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail" 752 return [] 753 | otherwise 754 = do 755 warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail" 756 return [] 757 758-- Writing .ghc.environment files 759-- 760 761writePlanGhcEnvironment :: FilePath 762 -> ElaboratedInstallPlan 763 -> ElaboratedSharedConfig 764 -> PostBuildProjectStatus 765 -> IO (Maybe FilePath) 766writePlanGhcEnvironment path 767 elaboratedInstallPlan 768 ElaboratedSharedConfig { 769 pkgConfigCompiler = compiler, 770 pkgConfigPlatform = platform 771 } 772 postBuildStatus 773 | compilerFlavor compiler == GHC 774 , supportsPkgEnvFiles (getImplInfo compiler) 775 --TODO: check ghcjs compat 776 = fmap Just $ writeGhcEnvironmentFile 777 path 778 platform (compilerVersion compiler) 779 (renderGhcEnvironmentFile path 780 elaboratedInstallPlan 781 postBuildStatus) 782 --TODO: [required eventually] support for writing user-wide package 783 -- environments, e.g. like a global project, but we would not put the 784 -- env file in the home dir, rather it lives under ~/.ghc/ 785 786writePlanGhcEnvironment _ _ _ _ = return Nothing 787 788renderGhcEnvironmentFile :: FilePath 789 -> ElaboratedInstallPlan 790 -> PostBuildProjectStatus 791 -> [GhcEnvironmentFileEntry] 792renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan 793 postBuildStatus = 794 headerComment 795 : simpleGhcEnvironmentFile packageDBs unitIds 796 where 797 headerComment = 798 GhcEnvFileComment 799 $ "This is a GHC environment file written by cabal. This means you can\n" 800 ++ "run ghc or ghci and get the environment of the project as a whole.\n" 801 ++ "But you still need to use cabal repl $target to get the environment\n" 802 ++ "of specific components (libs, exes, tests etc) because each one can\n" 803 ++ "have its own source dirs, cpp flags etc.\n\n" 804 unitIds = selectGhcEnvironmentFileLibraries postBuildStatus 805 packageDBs = relativePackageDBPaths projectRootDir $ 806 selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan 807 808 809argsEquivalentOfGhcEnvironmentFile 810 :: Compiler 811 -> DistDirLayout 812 -> ElaboratedInstallPlan 813 -> PostBuildProjectStatus 814 -> [String] 815argsEquivalentOfGhcEnvironmentFile compiler = 816 case compilerId compiler 817 of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc 818 CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc 819 CompilerId _ _ -> error "Only GHC and GHCJS are supported" 820 821-- TODO remove this when we drop support for non-.ghc.env ghc 822argsEquivalentOfGhcEnvironmentFileGhc 823 :: DistDirLayout 824 -> ElaboratedInstallPlan 825 -> PostBuildProjectStatus 826 -> [String] 827argsEquivalentOfGhcEnvironmentFileGhc 828 distDirLayout 829 elaboratedInstallPlan 830 postBuildStatus = 831 clearPackageDbStackFlag 832 ++ packageDbArgsDb packageDBs 833 ++ foldMap packageIdFlag packageIds 834 where 835 projectRootDir = distProjectRootDirectory distDirLayout 836 packageIds = selectGhcEnvironmentFileLibraries postBuildStatus 837 packageDBs = relativePackageDBPaths projectRootDir $ 838 selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan 839 -- TODO use proper flags? but packageDbArgsDb is private 840 clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"] 841 packageIdFlag uid = ["-package-id", display uid] 842 843 844-- We're producing an environment for users to use in ghci, so of course 845-- that means libraries only (can't put exes into the ghc package env!). 846-- The library environment should be /consistent/ with the environment 847-- that each of the packages in the project use (ie same lib versions). 848-- So that means all the normal library dependencies of all the things 849-- in the project (including deps of exes that are local to the project). 850-- We do not however want to include the dependencies of Setup.hs scripts, 851-- since these are generally uninteresting but also they need not in 852-- general be consistent with the library versions that packages local to 853-- the project use (recall that Setup.hs script's deps can be picked 854-- independently of other packages in the project). 855-- 856-- So, our strategy is as follows: 857-- 858-- produce a dependency graph of all the packages in the install plan, 859-- but only consider normal library deps as edges in the graph. Thus we 860-- exclude the dependencies on Setup.hs scripts (in the case of 861-- per-component granularity) or of Setup.hs scripts (in the case of 862-- per-package granularity). Then take a dependency closure, using as 863-- roots all the packages/components local to the project. This will 864-- exclude Setup scripts and their dependencies. 865-- 866-- Note: this algorithm will have to be adapted if/when the install plan 867-- is extended to cover multiple compilers at once, and may also have to 868-- change if we start to treat unshared deps of test suites in a similar 869-- way to how we treat Setup.hs script deps (ie being able to pick them 870-- independently). 871-- 872-- Since we had to use all the local packages, including exes, (as roots 873-- to find the libs) then those exes still end up in our list so we have 874-- to filter them out at the end. 875-- 876selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId] 877selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = 878 case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of 879 Nothing -> error "renderGhcEnvironmentFile: broken dep closure" 880 Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes 881 , hasUpToDateLib pkg ] 882 where 883 hasUpToDateLib planpkg = case planpkg of 884 -- A pre-existing global lib 885 InstallPlan.PreExisting _ -> True 886 887 -- A package in the store. Check it's a lib. 888 InstallPlan.Installed pkg -> elabRequiresRegistration pkg 889 890 -- A package we were installing this time, either destined for the store 891 -- or just locally. Check it's a lib and that it is probably up to date. 892 InstallPlan.Configured pkg -> 893 elabRequiresRegistration pkg 894 && installedUnitId pkg `Set.member` packagesProbablyUpToDate 895 896 897selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack 898selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = 899 -- If we have any inplace packages then their package db stack is the 900 -- one we should use since it'll include the store + the local db but 901 -- it's certainly possible to have no local inplace packages 902 -- e.g. just "extra" packages coming from the store. 903 case (inplacePackages, sourcePackages) of 904 ([], pkgs) -> checkSamePackageDBs pkgs 905 (pkgs, _) -> checkSamePackageDBs pkgs 906 where 907 checkSamePackageDBs pkgs = 908 case ordNub (map elabBuildPackageDBStack pkgs) of 909 [packageDbs] -> packageDbs 910 [] -> [] 911 _ -> error $ "renderGhcEnvironmentFile: packages with " 912 ++ "different package db stacks" 913 -- This should not happen at the moment but will happen as soon 914 -- as we support projects where we build packages with different 915 -- compilers, at which point we have to consider how to adapt 916 -- this feature, e.g. write out multiple env files, one for each 917 -- compiler / project profile. 918 919 inplacePackages = 920 [ srcpkg 921 | srcpkg <- sourcePackages 922 , elabBuildStyle srcpkg == BuildInplaceOnly ] 923 sourcePackages = 924 [ srcpkg 925 | pkg <- InstallPlan.toList elaboratedInstallPlan 926 , srcpkg <- maybeToList $ case pkg of 927 InstallPlan.Configured srcpkg -> Just srcpkg 928 InstallPlan.Installed srcpkg -> Just srcpkg 929 InstallPlan.PreExisting _ -> Nothing 930 ] 931 932relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack 933relativePackageDBPaths relroot = map (relativePackageDBPath relroot) 934 935relativePackageDBPath :: FilePath -> PackageDB -> PackageDB 936relativePackageDBPath relroot pkgdb = 937 case pkgdb of 938 GlobalPackageDB -> GlobalPackageDB 939 UserPackageDB -> UserPackageDB 940 SpecificPackageDB path -> SpecificPackageDB relpath 941 where relpath = makeRelative relroot path 942