cabal-install/src/Distribution/Client/ProjectPlanOutput.hs

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