{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Distribution.Client.ProjectPlanOutput
  ( -- * Plan output
    writePlanExternalRepresentation

    -- * Project status

    -- | Several outputs rely on having a general overview of
  , PostBuildProjectStatus (..)
  , updatePostBuildProjectStatus
  , createPackageEnvironment
  , writePlanGhcEnvironment
  , argsEquivalentOfGhcEnvironmentFile
  ) where

import Distribution.Client.DistDirLayout
import Distribution.Client.HashValue (hashValue, showHashValue)
import Distribution.Client.ProjectBuilding.Types
import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.Types.ConfiguredId (confInstId)
import Distribution.Client.Types.PackageLocation (PackageLocation (..))
import Distribution.Client.Types.Repo (RemoteRepo (..), Repo (..))
import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..))
import Distribution.Client.Version (cabalInstallVersion)

import qualified Distribution.Client.InstallPlan as InstallPlan
import qualified Distribution.Client.Utils.Json as J
import qualified Distribution.Simple.InstallDirs as InstallDirs

import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps

import qualified Distribution.Compat.Binary as Binary
import Distribution.Compat.Graph (Graph, Node)
import qualified Distribution.Compat.Graph as Graph
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import Distribution.Package
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.BuildPaths
  ( buildInfoPref
  , dllExtension
  , exeExtension
  )
import Distribution.Simple.Compiler
import Distribution.Simple.GHC
  ( GhcEnvironmentFileEntry (..)
  , GhcImplInfo (supportsPkgEnvFiles)
  , getImplInfo
  , simpleGhcEnvironmentFile
  , writeGhcEnvironmentFile
  )
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.Version
  ( mkVersion
  )
import Distribution.Utils.Path hiding
  ( (<.>)
  , (</>)
  )
import Distribution.Verbosity

import Distribution.Client.Compat.Prelude
import Prelude ()

import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BS
import qualified Data.Map as Map
import qualified Data.Set as Set

import System.FilePath
import System.IO

import Distribution.Simple.Program.GHC (packageDbArgsDb)

-----------------------------------------------------------------------------
-- Writing plan.json files
--

-- | Write out a representation of the elaborated install plan.
--
-- This is for the benefit of debugging and external tools like editors.
writePlanExternalRepresentation
  :: DistDirLayout
  -> ElaboratedInstallPlan
  -> ElaboratedSharedConfig
  -> IO ()
writePlanExternalRepresentation :: DistDirLayout
-> ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO ()
writePlanExternalRepresentation
  DistDirLayout
distDirLayout
  ElaboratedInstallPlan
elaboratedInstallPlan
  ElaboratedSharedConfig
elaboratedSharedConfig =
    String -> ByteString -> IO ()
writeFileAtomic (DistDirLayout -> String -> String
distProjectCacheFile DistDirLayout
distDirLayout String
"plan.json")
      (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString
        (Builder -> ByteString)
-> (Value -> Builder) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Builder
forall a. ToJSON a => a -> Builder
J.encodeToBuilder
      (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ DistDirLayout
-> ElaboratedInstallPlan -> ElaboratedSharedConfig -> Value
encodePlanAsJson DistDirLayout
distDirLayout ElaboratedInstallPlan
elaboratedInstallPlan ElaboratedSharedConfig
elaboratedSharedConfig

-- | Renders a subset of the elaborated install plan in a semi-stable JSON
-- format.
encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value
encodePlanAsJson :: DistDirLayout
-> ElaboratedInstallPlan -> ElaboratedSharedConfig -> Value
encodePlanAsJson DistDirLayout
distDirLayout ElaboratedInstallPlan
elaboratedInstallPlan ElaboratedSharedConfig
elaboratedSharedConfig =
  -- TODO: [nice to have] include all of the sharedPackageConfig and all of
  --      the parts of the elaboratedInstallPlan
  [Pair] -> Value
J.object
    [ String
"cabal-version" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= Version -> Value
forall a. Pretty a => a -> Value
jdisplay Version
cabalInstallVersion
    , String
"cabal-lib-version" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= Version -> Value
forall a. Pretty a => a -> Value
jdisplay Version
cabalVersion
    , String
"compiler-id"
        String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (String -> Value
J.String (String -> Value)
-> (ElaboratedSharedConfig -> String)
-> ElaboratedSharedConfig
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compiler -> String
showCompilerId (Compiler -> String)
-> (ElaboratedSharedConfig -> Compiler)
-> ElaboratedSharedConfig
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedSharedConfig -> Compiler
pkgConfigCompiler)
          ElaboratedSharedConfig
elaboratedSharedConfig
    , String
"os" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= OS -> Value
forall a. Pretty a => a -> Value
jdisplay OS
os
    , String
"arch" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= Arch -> Value
forall a. Pretty a => a -> Value
jdisplay Arch
arch
    , String
"install-plan" String -> [Value] -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= ElaboratedInstallPlan -> [Value]
installPlanToJ ElaboratedInstallPlan
elaboratedInstallPlan
    ]
  where
    plat :: Platform
    plat :: Platform
plat@(Platform Arch
arch OS
os) = ElaboratedSharedConfig -> Platform
pkgConfigPlatform ElaboratedSharedConfig
elaboratedSharedConfig

    installPlanToJ :: ElaboratedInstallPlan -> [J.Value]
    installPlanToJ :: ElaboratedInstallPlan -> [Value]
installPlanToJ = (ElaboratedPlanPackage -> Value)
-> [ElaboratedPlanPackage] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ElaboratedPlanPackage -> Value
planPackageToJ ([ElaboratedPlanPackage] -> [Value])
-> (ElaboratedInstallPlan -> [ElaboratedPlanPackage])
-> ElaboratedInstallPlan
-> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedInstallPlan -> [ElaboratedPlanPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList

    planPackageToJ :: ElaboratedPlanPackage -> J.Value
    planPackageToJ :: ElaboratedPlanPackage -> Value
planPackageToJ ElaboratedPlanPackage
pkg =
      case ElaboratedPlanPackage
pkg of
        InstallPlan.PreExisting InstalledPackageInfo
ipi -> InstalledPackageInfo -> Value
installedPackageInfoToJ InstalledPackageInfo
ipi
        InstallPlan.Configured ElaboratedConfiguredPackage
elab -> Bool -> ElaboratedConfiguredPackage -> Value
elaboratedPackageToJ Bool
False ElaboratedConfiguredPackage
elab
        InstallPlan.Installed ElaboratedConfiguredPackage
elab -> Bool -> ElaboratedConfiguredPackage -> Value
elaboratedPackageToJ Bool
True ElaboratedConfiguredPackage
elab
    -- Note that the plan.json currently only uses the elaborated plan,
    -- not the improved plan. So we will not get the Installed state for
    -- that case, but the code supports it in case we want to use this
    -- later in some use case where we want the status of the build.

    installedPackageInfoToJ :: InstalledPackageInfo -> J.Value
    installedPackageInfoToJ :: InstalledPackageInfo -> Value
installedPackageInfoToJ InstalledPackageInfo
ipi =
      -- Pre-existing packages lack configuration information such as their flag
      -- settings or non-lib components. We only get pre-existing packages for
      -- the global/core packages however, so this isn't generally a problem.
      -- So these packages are never local to the project.
      --
      [Pair] -> Value
J.object
        [ String
"type" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"pre-existing"
        , String
"id" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (UnitId -> Value
forall a. Pretty a => a -> Value
jdisplay (UnitId -> Value)
-> (InstalledPackageInfo -> UnitId)
-> InstalledPackageInfo
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId) InstalledPackageInfo
ipi
        , String
"pkg-name" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (PackageName -> Value
forall a. Pretty a => a -> Value
jdisplay (PackageName -> Value)
-> (InstalledPackageInfo -> PackageName)
-> InstalledPackageInfo
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (InstalledPackageInfo -> PackageIdentifier)
-> InstalledPackageInfo
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) InstalledPackageInfo
ipi
        , String
"pkg-version" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (Version -> Value
forall a. Pretty a => a -> Value
jdisplay (Version -> Value)
-> (InstalledPackageInfo -> Version)
-> InstalledPackageInfo
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version)
-> (InstalledPackageInfo -> PackageIdentifier)
-> InstalledPackageInfo
-> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) InstalledPackageInfo
ipi
        , String
"depends" String -> [Value] -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (UnitId -> Value) -> [UnitId] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> Value
forall a. Pretty a => a -> Value
jdisplay (InstalledPackageInfo -> [UnitId]
forall pkg. PackageInstalled pkg => pkg -> [UnitId]
installedDepends InstalledPackageInfo
ipi)
        ]

    elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value
    elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> Value
elaboratedPackageToJ Bool
isInstalled ElaboratedConfiguredPackage
elab =
      [Pair] -> Value
J.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
        [ String
"type"
            String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String
              ( if Bool
isInstalled
                  then String
"installed"
                  else String
"configured"
              )
        , String
"id" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (UnitId -> Value
forall a. Pretty a => a -> Value
jdisplay (UnitId -> Value)
-> (ElaboratedConfiguredPackage -> UnitId)
-> ElaboratedConfiguredPackage
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId) ElaboratedConfiguredPackage
elab
        , String
"pkg-name" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (PackageName -> Value
forall a. Pretty a => a -> Value
jdisplay (PackageName -> Value)
-> (ElaboratedConfiguredPackage -> PackageName)
-> ElaboratedConfiguredPackage
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (ElaboratedConfiguredPackage -> PackageIdentifier)
-> ElaboratedConfiguredPackage
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) ElaboratedConfiguredPackage
elab
        , String
"pkg-version" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (Version -> Value
forall a. Pretty a => a -> Value
jdisplay (Version -> Value)
-> (ElaboratedConfiguredPackage -> Version)
-> ElaboratedConfiguredPackage
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version)
-> (ElaboratedConfiguredPackage -> PackageIdentifier)
-> ElaboratedConfiguredPackage
-> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) ElaboratedConfiguredPackage
elab
        , String
"flags"
            String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= [Pair] -> Value
J.object
              [ FlagName -> String
PD.unFlagName FlagName
fn String -> Bool -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= Bool
v
              | (FlagName
fn, Bool
v) <- FlagAssignment -> [(FlagName, Bool)]
PD.unFlagAssignment (ElaboratedConfiguredPackage -> FlagAssignment
elabFlagAssignment ElaboratedConfiguredPackage
elab)
              ]
        , String
"style" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (Bool -> BuildStyle -> String
style2str (ElaboratedConfiguredPackage -> Bool
elabLocalToProject ElaboratedConfiguredPackage
elab) (ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
elab))
        , String
"pkg-src" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= PackageLocation (Maybe String) -> Value
packageLocationToJ (ElaboratedConfiguredPackage -> PackageLocation (Maybe String)
elabPkgSourceLocation ElaboratedConfiguredPackage
elab)
        ]
          [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [ String
"pkg-cabal-sha256" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (HashValue -> String
showHashValue HashValue
hash)
             | Just HashValue
hash <- [(ByteString -> HashValue) -> Maybe ByteString -> Maybe HashValue
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> HashValue
hashValue (ElaboratedConfiguredPackage -> Maybe ByteString
elabPkgDescriptionOverride ElaboratedConfiguredPackage
elab)]
             ]
          [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [ String
"pkg-src-sha256" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (HashValue -> String
showHashValue HashValue
hash)
             | Just HashValue
hash <- [ElaboratedConfiguredPackage -> Maybe HashValue
elabPkgSourceHash ElaboratedConfiguredPackage
elab]
             ]
          [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ ( case ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
elab of
                BuildInplaceOnly{} ->
                  [String
"dist-dir" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
dist_dir] [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair
buildInfoFileLocation]
                BuildStyle
BuildAndInstall ->
                  -- TODO: install dirs?
                  []
             )
          [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ case ElaboratedConfiguredPackage -> ElaboratedPackageOrComponent
elabPkgOrComp ElaboratedConfiguredPackage
elab of
            ElabPackage ElaboratedPackage
pkg ->
              let components :: Value
components =
                    [Pair] -> Value
J.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
                      [ Component -> String
comp2str Component
c
                        String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= [Pair] -> Value
J.object
                          ( [ String
"depends" String -> [Value] -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (ConfiguredId -> Value) -> [ConfiguredId] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (ComponentId -> Value
forall a. Pretty a => a -> Value
jdisplay (ComponentId -> Value)
-> (ConfiguredId -> ComponentId) -> ConfiguredId -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredId -> ComponentId
confInstId) (((ConfiguredId, Bool) -> ConfiguredId)
-> [(ConfiguredId, Bool)] -> [ConfiguredId]
forall a b. (a -> b) -> [a] -> [b]
map (ConfiguredId, Bool) -> ConfiguredId
forall a b. (a, b) -> a
fst [(ConfiguredId, Bool)]
ldeps)
                            , String
"exe-depends" String -> [Value] -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (ConfiguredId -> Value) -> [ConfiguredId] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (ComponentId -> Value
forall a. Pretty a => a -> Value
jdisplay (ComponentId -> Value)
-> (ConfiguredId -> ComponentId) -> ConfiguredId -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredId -> ComponentId
confInstId) [ConfiguredId]
edeps
                            ]
                              [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ Component -> [Pair]
bin_file Component
c
                          )
                      | (Component
c, ([(ConfiguredId, Bool)]
ldeps, [ConfiguredId]
edeps)) <-
                          ComponentDeps ([(ConfiguredId, Bool)], [ConfiguredId])
-> [(Component, ([(ConfiguredId, Bool)], [ConfiguredId]))]
forall a. ComponentDeps a -> [ComponentDep a]
ComponentDeps.toList (ComponentDeps ([(ConfiguredId, Bool)], [ConfiguredId])
 -> [(Component, ([(ConfiguredId, Bool)], [ConfiguredId]))])
-> ComponentDeps ([(ConfiguredId, Bool)], [ConfiguredId])
-> [(Component, ([(ConfiguredId, Bool)], [ConfiguredId]))]
forall a b. (a -> b) -> a -> b
$
                            ComponentDeps [(ConfiguredId, Bool)]
-> ComponentDeps [ConfiguredId]
-> ComponentDeps ([(ConfiguredId, Bool)], [ConfiguredId])
forall a b.
(Monoid a, Monoid b) =>
ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b)
ComponentDeps.zip
                              (ElaboratedPackage -> ComponentDeps [(ConfiguredId, Bool)]
pkgLibDependencies ElaboratedPackage
pkg)
                              (ElaboratedPackage -> ComponentDeps [ConfiguredId]
pkgExeDependencies ElaboratedPackage
pkg)
                      ]
               in [String
"components" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= Value
components]
            ElabComponent ElaboratedComponent
comp ->
              [ String
"depends" String -> [Value] -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (ConfiguredId -> Value) -> [ConfiguredId] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (ComponentId -> Value
forall a. Pretty a => a -> Value
jdisplay (ComponentId -> Value)
-> (ConfiguredId -> ComponentId) -> ConfiguredId -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredId -> ComponentId
confInstId) (((ConfiguredId, Bool) -> ConfiguredId)
-> [(ConfiguredId, Bool)] -> [ConfiguredId]
forall a b. (a -> b) -> [a] -> [b]
map (ConfiguredId, Bool) -> ConfiguredId
forall a b. (a, b) -> a
fst ([(ConfiguredId, Bool)] -> [ConfiguredId])
-> [(ConfiguredId, Bool)] -> [ConfiguredId]
forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)]
elabLibDependencies ElaboratedConfiguredPackage
elab)
              , String
"exe-depends" String -> [Value] -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (ComponentId -> Value) -> [ComponentId] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ComponentId -> Value
forall a. Pretty a => a -> Value
jdisplay (ElaboratedConfiguredPackage -> [ComponentId]
elabExeDependencies ElaboratedConfiguredPackage
elab)
              , String
"component-name" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (Component -> String
comp2str (ElaboratedComponent -> Component
compSolverName ElaboratedComponent
comp))
              ]
                [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ Component -> [Pair]
bin_file (ElaboratedComponent -> Component
compSolverName ElaboratedComponent
comp)
      where
        -- \| Only add build-info file location if the Setup.hs CLI
        -- is recent enough to be able to generate build info files.
        -- Otherwise, write 'null'.
        --
        -- Consumers of `plan.json` can use the nullability of this file location
        -- to indicate that the given component uses `build-type: Custom`
        -- with an old lib:Cabal version.
        buildInfoFileLocation :: J.Pair
        buildInfoFileLocation :: Pair
buildInfoFileLocation
          | ElaboratedConfiguredPackage -> Version
elabSetupScriptCliVersion ElaboratedConfiguredPackage
elab Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
3, Int
7, Int
0, Int
0] =
              String
"build-info" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= Value
J.Null
          | Bool
otherwise =
              String
"build-info" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (SymbolicPathX 'AllowAbsolute Any 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath (SymbolicPathX 'AllowAbsolute Any 'File -> String)
-> SymbolicPathX 'AllowAbsolute Any 'File -> String
forall a b. (a -> b) -> a -> b
$ SymbolicPath Any ('Dir Dist)
-> SymbolicPathX 'AllowAbsolute Any 'File
forall root.
SymbolicPath root ('Dir Dist) -> SymbolicPath root 'File
buildInfoPref (SymbolicPath Any ('Dir Dist)
 -> SymbolicPathX 'AllowAbsolute Any 'File)
-> SymbolicPath Any ('Dir Dist)
-> SymbolicPathX 'AllowAbsolute Any 'File
forall a b. (a -> b) -> a -> b
$ String -> SymbolicPath Any ('Dir Dist)
forall from (to :: FileOrDir). String -> SymbolicPath from to
makeSymbolicPath String
dist_dir)

        packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value
        packageLocationToJ :: PackageLocation (Maybe String) -> Value
packageLocationToJ PackageLocation (Maybe String)
pkgloc =
          case PackageLocation (Maybe String)
pkgloc of
            LocalUnpackedPackage String
local ->
              [Pair] -> Value
J.object
                [ String
"type" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"local"
                , String
"path" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
local
                ]
            LocalTarballPackage String
local ->
              [Pair] -> Value
J.object
                [ String
"type" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"local-tar"
                , String
"path" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
local
                ]
            RemoteTarballPackage URI
uri Maybe String
_ ->
              [Pair] -> Value
J.object
                [ String
"type" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"remote-tar"
                , String
"uri" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (URI -> String
forall a. Show a => a -> String
show URI
uri)
                ]
            RepoTarballPackage Repo
repo PackageIdentifier
_ Maybe String
_ ->
              [Pair] -> Value
J.object
                [ String
"type" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"repo-tar"
                , String
"repo" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= Repo -> Value
repoToJ Repo
repo
                ]
            RemoteSourceRepoPackage SourceRepoMaybe
srcRepo Maybe String
_ ->
              [Pair] -> Value
J.object
                [ String
"type" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"source-repo"
                , String
"source-repo" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= SourceRepoMaybe -> Value
sourceRepoToJ SourceRepoMaybe
srcRepo
                ]

        repoToJ :: Repo -> J.Value
        repoToJ :: Repo -> Value
repoToJ Repo
repo =
          case Repo
repo of
            RepoLocalNoIndex{String
LocalRepo
repoLocal :: LocalRepo
repoLocalDir :: String
repoLocal :: Repo -> LocalRepo
repoLocalDir :: Repo -> String
..} ->
              [Pair] -> Value
J.object
                [ String
"type" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"local-repo-no-index"
                , String
"path" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
repoLocalDir
                ]
            RepoRemote{String
RemoteRepo
repoLocalDir :: Repo -> String
repoRemote :: RemoteRepo
repoLocalDir :: String
repoRemote :: Repo -> RemoteRepo
..} ->
              [Pair] -> Value
J.object
                [ String
"type" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"remote-repo"
                , String
"uri" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (URI -> String
forall a. Show a => a -> String
show (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repoRemote))
                ]
            RepoSecure{String
RemoteRepo
repoLocalDir :: Repo -> String
repoRemote :: Repo -> RemoteRepo
repoRemote :: RemoteRepo
repoLocalDir :: String
..} ->
              [Pair] -> Value
J.object
                [ String
"type" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"secure-repo"
                , String
"uri" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (URI -> String
forall a. Show a => a -> String
show (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repoRemote))
                ]

        sourceRepoToJ :: SourceRepoMaybe -> J.Value
        sourceRepoToJ :: SourceRepoMaybe -> Value
sourceRepoToJ SourceRepositoryPackage{String
[String]
Maybe String
RepoType
srpType :: RepoType
srpLocation :: String
srpTag :: Maybe String
srpBranch :: Maybe String
srpSubdir :: Maybe String
srpCommand :: [String]
srpType :: forall (f :: * -> *). SourceRepositoryPackage f -> RepoType
srpLocation :: forall (f :: * -> *). SourceRepositoryPackage f -> String
srpTag :: forall (f :: * -> *). SourceRepositoryPackage f -> Maybe String
srpBranch :: forall (f :: * -> *). SourceRepositoryPackage f -> Maybe String
srpSubdir :: forall (f :: * -> *). SourceRepositoryPackage f -> f String
srpCommand :: forall (f :: * -> *). SourceRepositoryPackage f -> [String]
..} =
          [Pair] -> Value
J.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
            (Pair -> Bool) -> [Pair] -> [Pair]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
J.Null) (Value -> Bool) -> (Pair -> Value) -> Pair -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pair -> Value
forall a b. (a, b) -> b
snd) ([Pair] -> [Pair]) -> [Pair] -> [Pair]
forall a b. (a -> b) -> a -> b
$
              [ String
"type" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= RepoType -> Value
forall a. Pretty a => a -> Value
jdisplay RepoType
srpType
              , String
"location" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
srpLocation
              , String
"branch" String -> Maybe Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (String -> Value) -> Maybe String -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Value
J.String Maybe String
srpBranch
              , String
"tag" String -> Maybe Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (String -> Value) -> Maybe String -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Value
J.String Maybe String
srpTag
              , String
"subdir" String -> Maybe Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= (String -> Value) -> Maybe String -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Value
J.String Maybe String
srpSubdir
              ]

        dist_dir :: FilePath
        dist_dir :: String
dist_dir =
          DistDirLayout -> DistDirParams -> String
distBuildDirectory
            DistDirLayout
distDirLayout
            (ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams ElaboratedSharedConfig
elaboratedSharedConfig ElaboratedConfiguredPackage
elab)

        bin_file :: ComponentDeps.Component -> [J.Pair]
        bin_file :: Component -> [Pair]
bin_file Component
c = case Component
c of
          ComponentDeps.ComponentExe UnqualComponentName
s -> UnqualComponentName -> [Pair]
forall {p}. Pretty p => p -> [Pair]
bin_file' UnqualComponentName
s
          ComponentDeps.ComponentTest UnqualComponentName
s -> UnqualComponentName -> [Pair]
forall {p}. Pretty p => p -> [Pair]
bin_file' UnqualComponentName
s
          ComponentDeps.ComponentBench UnqualComponentName
s -> UnqualComponentName -> [Pair]
forall {p}. Pretty p => p -> [Pair]
bin_file' UnqualComponentName
s
          ComponentDeps.ComponentFLib UnqualComponentName
s -> UnqualComponentName -> [Pair]
forall a. (Pretty a, Show a) => a -> [Pair]
flib_file' UnqualComponentName
s
          Component
_ -> []
        bin_file' :: p -> [Pair]
bin_file' p
s =
          [String
"bin-file" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
bin]
          where
            bin :: String
bin =
              if BuildStyle -> Bool
isInplaceBuildStyle (ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
elab)
                then String
dist_dir String -> String -> String
</> String
"build" String -> String -> String
</> p -> String
forall a. Pretty a => a -> String
prettyShow p
s String -> String -> String
</> p -> String
forall a. Pretty a => a -> String
prettyShow p
s String -> String -> String
<.> Platform -> String
exeExtension Platform
plat
                else InstallDirs String -> String
forall dir. InstallDirs dir -> dir
InstallDirs.bindir (ElaboratedConfiguredPackage -> InstallDirs String
elabInstallDirs ElaboratedConfiguredPackage
elab) String -> String -> String
</> p -> String
forall a. Pretty a => a -> String
prettyShow p
s String -> String -> String
<.> Platform -> String
exeExtension Platform
plat

        flib_file' :: (Pretty a, Show a) => a -> [J.Pair]
        flib_file' :: forall a. (Pretty a, Show a) => a -> [Pair]
flib_file' a
s =
          [String
"bin-file" String -> Value -> Pair
forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
bin]
          where
            bin :: String
bin =
              if BuildStyle -> Bool
isInplaceBuildStyle (ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
elab)
                then String
dist_dir String -> String -> String
</> String
"build" String -> String -> String
</> a -> String
forall a. Pretty a => a -> String
prettyShow a
s String -> String -> String
</> (String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
prettyShow a
s) String -> String -> String
<.> Platform -> String
dllExtension Platform
plat
                else InstallDirs String -> String
forall dir. InstallDirs dir -> dir
InstallDirs.bindir (ElaboratedConfiguredPackage -> InstallDirs String
elabInstallDirs ElaboratedConfiguredPackage
elab) String -> String -> String
</> (String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
prettyShow a
s) String -> String -> String
<.> Platform -> String
dllExtension Platform
plat

    comp2str :: ComponentDeps.Component -> String
    comp2str :: Component -> String
comp2str = Component -> String
forall a. Pretty a => a -> String
prettyShow

    style2str :: Bool -> BuildStyle -> String
    style2str :: Bool -> BuildStyle -> String
style2str Bool
True BuildStyle
_ = String
"local"
    style2str Bool
False (BuildInplaceOnly MemoryOrDisk
OnDisk) = String
"inplace"
    style2str Bool
False (BuildInplaceOnly MemoryOrDisk
InMemory) = String
"interactive"
    style2str Bool
False BuildStyle
BuildAndInstall = String
"global"

    jdisplay :: Pretty a => a -> J.Value
    jdisplay :: forall a. Pretty a => a -> Value
jdisplay = String -> Value
J.String (String -> Value) -> (a -> String) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Pretty a => a -> String
prettyShow

-----------------------------------------------------------------------------
-- Project status
--

-- So, what is the status of a project after a build? That is, how do the
-- inputs (package source files etc) compare to the output artefacts (build
-- libs, exes etc)? Do the outputs reflect the current values of the inputs
-- or are outputs out of date or invalid?
--
-- First of all, what do we mean by out-of-date and what do we mean by
-- invalid? We think of the build system as a morally pure function that
-- computes the output artefacts given input values. We say an output artefact
-- is out of date when its value is not the value that would be computed by a
-- build given the current values of the inputs. An output artefact can be
-- out-of-date but still be perfectly usable; it simply correspond to a
-- previous state of the inputs.
--
-- On the other hand there are cases where output artefacts cannot safely be
-- used. For example libraries and dynamically linked executables cannot be
-- used when the libs they depend on change without them being recompiled
-- themselves. Whether an artefact is still usable depends on what it is, e.g.
-- dynamically linked vs statically linked and on how it gets updated (e.g.
-- only atomically on success or if failure can leave invalid states). We need
-- a definition (or two) that is independent of the kind of artefact and can
-- be computed just in terms of changes in package graphs, but are still
-- useful for determining when particular kinds of artefacts are invalid.
--
-- Note that when we talk about packages in this context we just mean nodes
-- in the elaborated install plan, which can be components or packages.
--
-- There's obviously a close connection between packages being out of date and
-- their output artefacts being unusable: most of the time if a package
-- remains out of date at the end of a build then some of its output artefacts
-- will be unusable. That is true most of the time because a build will have
-- attempted to build one of the out-of-date package's dependencies. If the
-- build of the dependency succeeded then it changed output artefacts (like
-- libs) and if it failed then it may have failed after already changing
-- things (think failure after updating some but not all .hi files).
--
-- There are a few reasons we may end up with still-usable output artefacts
-- for a package even when it remains out of date at the end of a build.
-- Firstly if executing a plan fails then packages can be skipped, and thus we
-- may have packages where all their dependencies were skipped. Secondly we
-- have artefacts like statically linked executables which are not affected by
-- libs they depend on being recompiled. Furthermore, packages can be out of
-- date due to changes in build tools or Setup.hs scripts they depend on, but
-- again libraries or executables in those out-of-date packages remain usable.
--
-- So we have two useful definitions of invalid. Both are useful, for
-- different purposes, so we will compute both. The first corresponds to the
-- invalid libraries and dynamic executables. We say a package is invalid by
-- changed deps if any of the packages it depends on (via library dep edges)
-- were rebuilt (successfully or unsuccessfully). The second definition
-- corresponds to invalid static executables. We say a package is invalid by
-- a failed build simply if the package was built but unsuccessfully.
--
-- So how do we find out what packages are out of date or invalid?
--
-- Obviously we know something for all the packages that were part of the plan
-- that was executed, but that is just a subset since we prune the plan down
-- to the targets and their dependencies.
--
-- Recall the steps we go though:
--
-- + starting with the initial improved plan (this is the full project);
--
-- + prune the plan to the user's build targets;
--
-- + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap
--   covering the pruned subset of the original plan;
--
-- + execute the plan giving us BuildOutcomes which tell us success/failure
--   for each package.
--
-- So given that the BuildStatusMap and BuildOutcomes do not cover everything
-- in the original plan, what can they tell us about the original plan?
--
-- The BuildStatusMap tells us directly that some packages are up to date and
-- others out of date (but only for the pruned subset). But we know that
-- everything that is a reverse dependency of an out-of-date package is itself
-- out-of-date (whether or not it is in the pruned subset). Of course after
-- a build the BuildOutcomes may tell us that some of those out-of-date
-- packages are now up to date (ie a successful build outcome).
--
-- The difference is packages that are reverse dependencies of out-of-date
-- packages but are not brought up-to-date by the build (i.e. did not have
-- successful outcomes, either because they failed or were not in the pruned
-- subset to be built). We also know which packages were rebuilt, so we can
-- use this to find the now-invalid packages.
--
-- Note that there are still packages for which we cannot discover full status
-- information. There may be packages outside of the pruned plan that do not
-- depend on packages within the pruned plan that were discovered to be
-- out-of-date. For these packages we do not know if their build artefacts
-- are out-of-date or not. We do know however that they are not invalid, as
-- that's not possible given our definition of invalid. Intuitively it is
-- because we have not disturbed anything that these packages depend on, e.g.
-- we've not rebuilt any libs they depend on. Recall that our widest
-- definition of invalid was only concerned about dependencies on libraries
-- (to cover problems like shared libs or GHC seeing inconsistent .hi files).
--
-- So our algorithm for out-of-date packages is relatively simple: take the
-- reverse dependency closure in the original improved plan (pre-pruning) of
-- the out-of-date packages (as determined by the BuildStatusMap from the dry
-- run). That gives a set of packages that were definitely out of date after
-- the dry run. Now we remove from this set the packages that the
-- BuildOutcomes tells us are now up-to-date after the build. The remaining
-- set is the out-of-date packages.
--
-- As for packages that are invalid by changed deps, we start with the plan
-- dependency graph but keep only those edges that point to libraries (so
-- ignoring deps on exes and setup scripts). We take the packages for which a
-- build was attempted (successfully or unsuccessfully, but not counting
-- knock-on failures) and take the reverse dependency closure. We delete from
-- this set all the packages that were built successfully. Note that we do not
-- need to intersect with the out-of-date packages since this follows
-- automatically: all rev deps of packages we attempted to build must have
-- been out of date at the start of the build, and if they were not built
-- successfully then they're still out of date -- meeting our definition of
-- invalid.

type PackageIdSet = Set UnitId
type PackagesUpToDate = PackageIdSet

data PostBuildProjectStatus = PostBuildProjectStatus
  { PostBuildProjectStatus -> PackagesUpToDate
packagesDefinitelyUpToDate :: PackageIdSet
  -- ^ Packages that are known to be up to date. These were found to be
  -- up to date before the build, or they have a successful build outcome
  -- afterwards.
  --
  -- This does not include any packages outside of the subset of the plan
  -- that was executed because we did not check those and so don't know
  -- for sure that they're still up to date.
  , PostBuildProjectStatus -> PackagesUpToDate
packagesProbablyUpToDate :: PackageIdSet
  -- ^ Packages that are probably still up to date (and at least not
  -- known to be out of date, and certainly not invalid). This includes
  -- 'packagesDefinitelyUpToDate' plus packages that were up to date
  -- previously and are outside of the subset of the plan that was
  -- executed. It excludes 'packagesOutOfDate'.
  , PostBuildProjectStatus -> PackagesUpToDate
packagesOutOfDate :: PackageIdSet
  -- ^ Packages that are known to be out of date. These are packages
  -- that were determined to be out of date before the build, and they
  -- do not have a successful build outcome afterwards.
  --
  -- Note that this can sometimes include packages outside of the subset
  -- of the plan that was executed. For example suppose package A and B
  -- depend on C, and A is the target so only A and C are in the subset
  -- to be built. Now suppose C is found to have changed, then both A
  -- and B are out-of-date before the build and since B is outside the
  -- subset to be built then it will remain out of date.
  --
  -- Note also that this is /not/ the inverse of
  -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'.
  -- There are packages where we have no information (ones that were not
  -- in the subset of the plan that was executed).
  , PostBuildProjectStatus -> PackagesUpToDate
packagesInvalidByChangedLibDeps :: PackageIdSet
  -- ^ Packages that depend on libraries that have changed during the
  -- build (either build success or failure).
  --
  -- This corresponds to the fact that libraries and dynamic executables
  -- are invalid once any of the libs they depend on change.
  --
  -- This does include packages that themselves failed (i.e. it is a
  -- superset of 'packagesInvalidByFailedBuild'). It does not include
  -- changes in dependencies on executables (i.e. build tools).
  , PostBuildProjectStatus -> PackagesUpToDate
packagesInvalidByFailedBuild :: PackageIdSet
  -- ^ Packages that themselves failed during the build (i.e. them
  -- directly not a dep).
  --
  -- This corresponds to the fact that static executables are invalid
  -- in unlucky circumstances such as linking failing half way though,
  -- or data file generation failing.
  --
  -- This is a subset of 'packagesInvalidByChangedLibDeps'.
  , PostBuildProjectStatus -> Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
  -- ^ A subset of the plan graph, including only dependency-on-library
  -- edges. That is, dependencies /on/ libraries, not dependencies /of/
  -- libraries. This tells us all the libraries that packages link to.
  --
  -- This is here as a convenience, as strictly speaking it's not status
  -- as it's just a function of the original 'ElaboratedInstallPlan'.
  , PostBuildProjectStatus -> PackagesUpToDate
packagesBuildLocal :: PackageIdSet
  -- ^ As a convenience for 'Set.intersection' with any of the other
  -- 'PackageIdSet's to select only packages that are part of the
  -- project locally (i.e. with a local source dir).
  , PostBuildProjectStatus -> PackagesUpToDate
packagesBuildInplace :: PackageIdSet
  -- ^ As a convenience for 'Set.intersection' with any of the other
  -- 'PackageIdSet's to select only packages that are being built
  -- in-place within the project (i.e. not destined for the store).
  , PostBuildProjectStatus -> PackagesUpToDate
packagesAlreadyInStore :: PackageIdSet
  -- ^ As a convenience for 'Set.intersection' or 'Set.difference' with
  -- any of the other 'PackageIdSet's to select only packages that were
  -- pre-installed or already in the store prior to the build.
  }

-- | Work out which packages are out of date or invalid after a build.
postBuildProjectStatus
  :: ElaboratedInstallPlan
  -> PackagesUpToDate
  -> BuildStatusMap
  -> BuildOutcomes
  -> PostBuildProjectStatus
postBuildProjectStatus :: ElaboratedInstallPlan
-> PackagesUpToDate
-> BuildStatusMap
-> BuildOutcomes
-> PostBuildProjectStatus
postBuildProjectStatus
  ElaboratedInstallPlan
plan
  PackagesUpToDate
previousPackagesUpToDate
  BuildStatusMap
pkgBuildStatus
  BuildOutcomes
buildOutcomes =
    PostBuildProjectStatus
      { PackagesUpToDate
packagesDefinitelyUpToDate :: PackagesUpToDate
packagesDefinitelyUpToDate :: PackagesUpToDate
packagesDefinitelyUpToDate
      , PackagesUpToDate
packagesProbablyUpToDate :: PackagesUpToDate
packagesProbablyUpToDate :: PackagesUpToDate
packagesProbablyUpToDate
      , PackagesUpToDate
packagesOutOfDate :: PackagesUpToDate
packagesOutOfDate :: PackagesUpToDate
packagesOutOfDate
      , PackagesUpToDate
packagesInvalidByChangedLibDeps :: PackagesUpToDate
packagesInvalidByChangedLibDeps :: PackagesUpToDate
packagesInvalidByChangedLibDeps
      , PackagesUpToDate
packagesInvalidByFailedBuild :: PackagesUpToDate
packagesInvalidByFailedBuild :: PackagesUpToDate
packagesInvalidByFailedBuild
      , -- convenience stuff
        Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph
      , PackagesUpToDate
packagesBuildLocal :: PackagesUpToDate
packagesBuildLocal :: PackagesUpToDate
packagesBuildLocal
      , PackagesUpToDate
packagesBuildInplace :: PackagesUpToDate
packagesBuildInplace :: PackagesUpToDate
packagesBuildInplace
      , PackagesUpToDate
packagesAlreadyInStore :: PackagesUpToDate
packagesAlreadyInStore :: PackagesUpToDate
packagesAlreadyInStore
      }
    where
      packagesDefinitelyUpToDate :: PackagesUpToDate
packagesDefinitelyUpToDate =
        PackagesUpToDate
packagesUpToDatePreBuild
          PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PackagesUpToDate
packagesSuccessfulPostBuild

      packagesProbablyUpToDate :: PackagesUpToDate
packagesProbablyUpToDate =
        PackagesUpToDate
packagesDefinitelyUpToDate
          PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (PackagesUpToDate
previousPackagesUpToDate' PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` PackagesUpToDate
packagesOutOfDatePreBuild)

      packagesOutOfDate :: PackagesUpToDate
packagesOutOfDate =
        PackagesUpToDate
packagesOutOfDatePreBuild PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` PackagesUpToDate
packagesSuccessfulPostBuild

      packagesInvalidByChangedLibDeps :: PackagesUpToDate
packagesInvalidByChangedLibDeps =
        PackagesUpToDate
packagesDepOnChangedLib PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` PackagesUpToDate
packagesSuccessfulPostBuild

      packagesInvalidByFailedBuild :: PackagesUpToDate
packagesInvalidByFailedBuild =
        PackagesUpToDate
packagesFailurePostBuild

      -- Note: if any of the intermediate values below turn out to be useful in
      -- their own right then we can simply promote them to the result record

      -- The previous set of up-to-date packages will contain bogus package ids
      -- when the solver plan or config contributing to the hash changes.
      -- So keep only the ones where the package id (i.e. hash) is the same.
      previousPackagesUpToDate' :: PackagesUpToDate
previousPackagesUpToDate' =
        PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection
          PackagesUpToDate
previousPackagesUpToDate
          (ElaboratedInstallPlan -> PackagesUpToDate
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> PackagesUpToDate
InstallPlan.keysSet ElaboratedInstallPlan
plan)

      packagesUpToDatePreBuild :: PackagesUpToDate
packagesUpToDatePreBuild =
        (UnitId -> Bool) -> PackagesUpToDate -> PackagesUpToDate
forall a. (a -> Bool) -> Set a -> Set a
Set.filter
          (\UnitId
ipkgid -> Bool -> Bool
not (Bool -> UnitId -> Bool
lookupBuildStatusRequiresBuild Bool
True UnitId
ipkgid))
          -- For packages not in the plan subset we did the dry-run on we don't
          -- know anything about their status, so not known to be /up to date/.
          (ElaboratedInstallPlan -> PackagesUpToDate
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> PackagesUpToDate
InstallPlan.keysSet ElaboratedInstallPlan
plan)

      packagesOutOfDatePreBuild :: PackagesUpToDate
packagesOutOfDatePreBuild =
        [UnitId] -> PackagesUpToDate
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> PackagesUpToDate)
-> ([ElaboratedPlanPackage] -> [UnitId])
-> [ElaboratedPlanPackage]
-> PackagesUpToDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ElaboratedPlanPackage -> UnitId)
-> [ElaboratedPlanPackage] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map ElaboratedPlanPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ([ElaboratedPlanPackage] -> PackagesUpToDate)
-> [ElaboratedPlanPackage] -> PackagesUpToDate
forall a b. (a -> b) -> a -> b
$
          ElaboratedInstallPlan -> [UnitId] -> [ElaboratedPlanPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> [UnitId] -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.reverseDependencyClosure
            ElaboratedInstallPlan
plan
            [ UnitId
ipkgid
            | ElaboratedPlanPackage
pkg <- ElaboratedInstallPlan -> [ElaboratedPlanPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
plan
            , let ipkgid :: UnitId
ipkgid = ElaboratedPlanPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedPlanPackage
pkg
            , Bool -> UnitId -> Bool
lookupBuildStatusRequiresBuild Bool
False UnitId
ipkgid
            -- For packages not in the plan subset we did the dry-run on we don't
            -- know anything about their status, so not known to be /out of date/.
            ]

      packagesSuccessfulPostBuild :: PackagesUpToDate
packagesSuccessfulPostBuild =
        [UnitId] -> PackagesUpToDate
forall a. Ord a => [a] -> Set a
Set.fromList
          [UnitId
ikgid | (UnitId
ikgid, Right BuildResult
_) <- BuildOutcomes -> [(UnitId, BuildOutcome)]
forall k a. Map k a -> [(k, a)]
Map.toList BuildOutcomes
buildOutcomes]

      -- direct failures, not failures due to deps
      packagesFailurePostBuild :: PackagesUpToDate
packagesFailurePostBuild =
        [UnitId] -> PackagesUpToDate
forall a. Ord a => [a] -> Set a
Set.fromList
          [ UnitId
ikgid
          | (UnitId
ikgid, Left BuildFailure
failure) <- BuildOutcomes -> [(UnitId, BuildOutcome)]
forall k a. Map k a -> [(k, a)]
Map.toList BuildOutcomes
buildOutcomes
          , case BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
failure of
              DependentFailed PackageIdentifier
_ -> Bool
False
              BuildFailureReason
_ -> Bool
True
          ]

      -- Packages that have a library dependency on a package for which a build
      -- was attempted
      packagesDepOnChangedLib :: PackagesUpToDate
packagesDepOnChangedLib =
        [UnitId] -> PackagesUpToDate
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> PackagesUpToDate)
-> ([Node UnitId ElaboratedPlanPackage] -> [UnitId])
-> [Node UnitId ElaboratedPlanPackage]
-> PackagesUpToDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node UnitId ElaboratedPlanPackage -> UnitId)
-> [Node UnitId ElaboratedPlanPackage] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map Node UnitId ElaboratedPlanPackage -> UnitId
Node UnitId ElaboratedPlanPackage
-> Key (Node UnitId ElaboratedPlanPackage)
forall a. IsNode a => a -> Key a
Graph.nodeKey ([Node UnitId ElaboratedPlanPackage] -> PackagesUpToDate)
-> [Node UnitId ElaboratedPlanPackage] -> PackagesUpToDate
forall a b. (a -> b) -> a -> b
$
          [Node UnitId ElaboratedPlanPackage]
-> Maybe [Node UnitId ElaboratedPlanPackage]
-> [Node UnitId ElaboratedPlanPackage]
forall a. a -> Maybe a -> a
fromMaybe (String -> [Node UnitId ElaboratedPlanPackage]
forall a. HasCallStack => String -> a
error String
"packagesBuildStatusAfterBuild: broken dep closure") (Maybe [Node UnitId ElaboratedPlanPackage]
 -> [Node UnitId ElaboratedPlanPackage])
-> Maybe [Node UnitId ElaboratedPlanPackage]
-> [Node UnitId ElaboratedPlanPackage]
forall a b. (a -> b) -> a -> b
$
            Graph (Node UnitId ElaboratedPlanPackage)
-> [Key (Node UnitId ElaboratedPlanPackage)]
-> Maybe [Node UnitId ElaboratedPlanPackage]
forall a. Graph a -> [Key a] -> Maybe [a]
Graph.revClosure
              Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph
              ( Map UnitId (BuildStatus, BuildOutcome) -> [UnitId]
Map UnitId (BuildStatus, BuildOutcome)
-> [Key (Node UnitId ElaboratedPlanPackage)]
forall k a. Map k a -> [k]
Map.keys
                  (Map UnitId (BuildStatus, BuildOutcome)
 -> [Key (Node UnitId ElaboratedPlanPackage)])
-> (Map UnitId (BuildStatus, BuildOutcome)
    -> Map UnitId (BuildStatus, BuildOutcome))
-> Map UnitId (BuildStatus, BuildOutcome)
-> [Key (Node UnitId ElaboratedPlanPackage)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BuildStatus, BuildOutcome) -> Bool)
-> Map UnitId (BuildStatus, BuildOutcome)
-> Map UnitId (BuildStatus, BuildOutcome)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((BuildStatus -> BuildOutcome -> Bool)
-> (BuildStatus, BuildOutcome) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry BuildStatus -> BuildOutcome -> Bool
buildAttempted)
                  (Map UnitId (BuildStatus, BuildOutcome)
 -> [Key (Node UnitId ElaboratedPlanPackage)])
-> Map UnitId (BuildStatus, BuildOutcome)
-> [Key (Node UnitId ElaboratedPlanPackage)]
forall a b. (a -> b) -> a -> b
$ (BuildStatus -> BuildOutcome -> (BuildStatus, BuildOutcome))
-> BuildStatusMap
-> BuildOutcomes
-> Map UnitId (BuildStatus, BuildOutcome)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) BuildStatusMap
pkgBuildStatus BuildOutcomes
buildOutcomes
              )

      -- The plan graph but only counting dependency-on-library edges
      packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
      packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph =
        [Node UnitId ElaboratedPlanPackage]
-> Graph (Node UnitId ElaboratedPlanPackage)
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList
          [ ElaboratedPlanPackage
-> UnitId -> [UnitId] -> Node UnitId ElaboratedPlanPackage
forall k a. a -> k -> [k] -> Node k a
Graph.N ElaboratedPlanPackage
pkg (ElaboratedPlanPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedPlanPackage
pkg) [UnitId]
libdeps
          | ElaboratedPlanPackage
pkg <- ElaboratedInstallPlan -> [ElaboratedPlanPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
plan
          , let libdeps :: [UnitId]
libdeps = case ElaboratedPlanPackage
pkg of
                  InstallPlan.PreExisting InstalledPackageInfo
ipkg -> InstalledPackageInfo -> [UnitId]
forall pkg. PackageInstalled pkg => pkg -> [UnitId]
installedDepends InstalledPackageInfo
ipkg
                  InstallPlan.Configured ElaboratedConfiguredPackage
srcpkg -> ElaboratedConfiguredPackage -> [UnitId]
elabLibDeps ElaboratedConfiguredPackage
srcpkg
                  InstallPlan.Installed ElaboratedConfiguredPackage
srcpkg -> ElaboratedConfiguredPackage -> [UnitId]
elabLibDeps ElaboratedConfiguredPackage
srcpkg
          ]

      elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId]
      elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId]
elabLibDeps = (ConfiguredId -> UnitId) -> [ConfiguredId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (ComponentId -> UnitId
newSimpleUnitId (ComponentId -> UnitId)
-> (ConfiguredId -> ComponentId) -> ConfiguredId -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredId -> ComponentId
confInstId) ([ConfiguredId] -> [UnitId])
-> (ElaboratedConfiguredPackage -> [ConfiguredId])
-> ElaboratedConfiguredPackage
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConfiguredId, Bool) -> ConfiguredId)
-> [(ConfiguredId, Bool)] -> [ConfiguredId]
forall a b. (a -> b) -> [a] -> [b]
map (ConfiguredId, Bool) -> ConfiguredId
forall a b. (a, b) -> a
fst ([(ConfiguredId, Bool)] -> [ConfiguredId])
-> (ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)])
-> ElaboratedConfiguredPackage
-> [ConfiguredId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)]
elabLibDependencies

      -- Was a build was attempted for this package?
      -- If it doesn't have both a build status and outcome then the answer is no.
      buildAttempted :: BuildStatus -> BuildOutcome -> Bool
      -- And not if it didn't need rebuilding in the first place.
      buildAttempted :: BuildStatus -> BuildOutcome -> Bool
buildAttempted BuildStatus
buildStatus BuildOutcome
_buildOutcome
        | Bool -> Bool
not (BuildStatus -> Bool
buildStatusRequiresBuild BuildStatus
buildStatus) =
            Bool
False
      -- And not if it was skipped due to a dep failing first.
      buildAttempted BuildStatus
_ (Left BuildFailure{BuildFailureReason
buildFailureReason :: BuildFailure -> BuildFailureReason
buildFailureReason :: BuildFailureReason
buildFailureReason})
        | DependentFailed PackageIdentifier
_ <- BuildFailureReason
buildFailureReason =
            Bool
False
      -- Otherwise, succeeded or failed, yes the build was tried.
      buildAttempted BuildStatus
_ (Left BuildFailure{}) = Bool
True
      buildAttempted BuildStatus
_ (Right BuildResult
_) = Bool
True

      lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool
      lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool
lookupBuildStatusRequiresBuild Bool
def UnitId
ipkgid =
        case UnitId -> BuildStatusMap -> Maybe BuildStatus
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
ipkgid BuildStatusMap
pkgBuildStatus of
          Maybe BuildStatus
Nothing -> Bool
def -- Not in the plan subset we did the dry-run on
          Just BuildStatus
buildStatus -> BuildStatus -> Bool
buildStatusRequiresBuild BuildStatus
buildStatus

      packagesBuildLocal :: Set UnitId
      packagesBuildLocal :: PackagesUpToDate
packagesBuildLocal =
        (ElaboratedPlanPackage -> Bool) -> PackagesUpToDate
selectPlanPackageIdSet ((ElaboratedPlanPackage -> Bool) -> PackagesUpToDate)
-> (ElaboratedPlanPackage -> Bool) -> PackagesUpToDate
forall a b. (a -> b) -> a -> b
$ \ElaboratedPlanPackage
pkg ->
          case ElaboratedPlanPackage
pkg of
            InstallPlan.PreExisting InstalledPackageInfo
_ -> Bool
False
            InstallPlan.Installed ElaboratedConfiguredPackage
_ -> Bool
False
            InstallPlan.Configured ElaboratedConfiguredPackage
srcpkg -> ElaboratedConfiguredPackage -> Bool
elabLocalToProject ElaboratedConfiguredPackage
srcpkg

      packagesBuildInplace :: Set UnitId
      packagesBuildInplace :: PackagesUpToDate
packagesBuildInplace =
        (ElaboratedPlanPackage -> Bool) -> PackagesUpToDate
selectPlanPackageIdSet ((ElaboratedPlanPackage -> Bool) -> PackagesUpToDate)
-> (ElaboratedPlanPackage -> Bool) -> PackagesUpToDate
forall a b. (a -> b) -> a -> b
$ \ElaboratedPlanPackage
pkg ->
          case ElaboratedPlanPackage
pkg of
            InstallPlan.PreExisting InstalledPackageInfo
_ -> Bool
False
            InstallPlan.Installed ElaboratedConfiguredPackage
_ -> Bool
False
            InstallPlan.Configured ElaboratedConfiguredPackage
srcpkg -> BuildStyle -> Bool
isInplaceBuildStyle (ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
srcpkg)

      packagesAlreadyInStore :: Set UnitId
      packagesAlreadyInStore :: PackagesUpToDate
packagesAlreadyInStore =
        (ElaboratedPlanPackage -> Bool) -> PackagesUpToDate
selectPlanPackageIdSet ((ElaboratedPlanPackage -> Bool) -> PackagesUpToDate)
-> (ElaboratedPlanPackage -> Bool) -> PackagesUpToDate
forall a b. (a -> b) -> a -> b
$ \ElaboratedPlanPackage
pkg ->
          case ElaboratedPlanPackage
pkg of
            InstallPlan.PreExisting InstalledPackageInfo
_ -> Bool
True
            InstallPlan.Installed ElaboratedConfiguredPackage
_ -> Bool
True
            InstallPlan.Configured ElaboratedConfiguredPackage
_ -> Bool
False

      selectPlanPackageIdSet
        :: ( InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
             -> Bool
           )
        -> Set UnitId
      selectPlanPackageIdSet :: (ElaboratedPlanPackage -> Bool) -> PackagesUpToDate
selectPlanPackageIdSet ElaboratedPlanPackage -> Bool
p =
        Map UnitId ElaboratedPlanPackage -> PackagesUpToDate
forall k a. Map k a -> Set k
Map.keysSet
          (Map UnitId ElaboratedPlanPackage -> PackagesUpToDate)
-> (Map UnitId ElaboratedPlanPackage
    -> Map UnitId ElaboratedPlanPackage)
-> Map UnitId ElaboratedPlanPackage
-> PackagesUpToDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ElaboratedPlanPackage -> Bool)
-> Map UnitId ElaboratedPlanPackage
-> Map UnitId ElaboratedPlanPackage
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ElaboratedPlanPackage -> Bool
p
          (Map UnitId ElaboratedPlanPackage -> PackagesUpToDate)
-> Map UnitId ElaboratedPlanPackage -> PackagesUpToDate
forall a b. (a -> b) -> a -> b
$ ElaboratedInstallPlan -> Map UnitId ElaboratedPlanPackage
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
InstallPlan.toMap ElaboratedInstallPlan
plan

updatePostBuildProjectStatus
  :: Verbosity
  -> DistDirLayout
  -> ElaboratedInstallPlan
  -> BuildStatusMap
  -> BuildOutcomes
  -> IO PostBuildProjectStatus
updatePostBuildProjectStatus :: Verbosity
-> DistDirLayout
-> ElaboratedInstallPlan
-> BuildStatusMap
-> BuildOutcomes
-> IO PostBuildProjectStatus
updatePostBuildProjectStatus
  Verbosity
verbosity
  DistDirLayout
distDirLayout
  ElaboratedInstallPlan
elaboratedInstallPlan
  BuildStatusMap
pkgsBuildStatus
  BuildOutcomes
buildOutcomes = do
    -- Read the previous up-to-date set, update it and write it back
    PackagesUpToDate
previousUpToDate <- DistDirLayout -> IO PackagesUpToDate
readPackagesUpToDateCacheFile DistDirLayout
distDirLayout
    let currentBuildStatus :: PostBuildProjectStatus
currentBuildStatus@PostBuildProjectStatus{PackagesUpToDate
Graph (Node UnitId ElaboratedPlanPackage)
packagesDefinitelyUpToDate :: PostBuildProjectStatus -> PackagesUpToDate
packagesProbablyUpToDate :: PostBuildProjectStatus -> PackagesUpToDate
packagesOutOfDate :: PostBuildProjectStatus -> PackagesUpToDate
packagesInvalidByChangedLibDeps :: PostBuildProjectStatus -> PackagesUpToDate
packagesInvalidByFailedBuild :: PostBuildProjectStatus -> PackagesUpToDate
packagesLibDepGraph :: PostBuildProjectStatus -> Graph (Node UnitId ElaboratedPlanPackage)
packagesBuildLocal :: PostBuildProjectStatus -> PackagesUpToDate
packagesBuildInplace :: PostBuildProjectStatus -> PackagesUpToDate
packagesAlreadyInStore :: PostBuildProjectStatus -> PackagesUpToDate
packagesDefinitelyUpToDate :: PackagesUpToDate
packagesProbablyUpToDate :: PackagesUpToDate
packagesOutOfDate :: PackagesUpToDate
packagesInvalidByChangedLibDeps :: PackagesUpToDate
packagesInvalidByFailedBuild :: PackagesUpToDate
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
packagesBuildLocal :: PackagesUpToDate
packagesBuildInplace :: PackagesUpToDate
packagesAlreadyInStore :: PackagesUpToDate
..} =
          ElaboratedInstallPlan
-> PackagesUpToDate
-> BuildStatusMap
-> BuildOutcomes
-> PostBuildProjectStatus
postBuildProjectStatus
            ElaboratedInstallPlan
elaboratedInstallPlan
            PackagesUpToDate
previousUpToDate
            BuildStatusMap
pkgsBuildStatus
            BuildOutcomes
buildOutcomes
    let currentUpToDate :: PackagesUpToDate
currentUpToDate = PackagesUpToDate
packagesProbablyUpToDate
    DistDirLayout -> PackagesUpToDate -> IO ()
writePackagesUpToDateCacheFile DistDirLayout
distDirLayout PackagesUpToDate
currentUpToDate

    -- Report various possibly interesting things
    -- We additionally intersect with the packagesBuildInplace so that
    -- we don't show huge numbers of boring packages from the store.
    Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"packages definitely up to date: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet
          ( PackagesUpToDate
packagesDefinitelyUpToDate
              PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` PackagesUpToDate
packagesBuildInplace
          )

    Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"packages previously probably up to date: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet
          ( PackagesUpToDate
previousUpToDate
              PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` PackagesUpToDate
packagesBuildInplace
          )

    Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"packages now probably up to date: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet
          ( PackagesUpToDate
packagesProbablyUpToDate
              PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` PackagesUpToDate
packagesBuildInplace
          )

    Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"packages newly up to date: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet
          ( PackagesUpToDate
packagesDefinitelyUpToDate
              PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` PackagesUpToDate
previousUpToDate
              PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` PackagesUpToDate
packagesBuildInplace
          )

    Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"packages out to date: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet
          ( PackagesUpToDate
packagesOutOfDate
              PackagesUpToDate -> PackagesUpToDate -> PackagesUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` PackagesUpToDate
packagesBuildInplace
          )

    Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"packages invalid due to dep change: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet PackagesUpToDate
packagesInvalidByChangedLibDeps

    Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"packages invalid due to build failure: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet PackagesUpToDate
packagesInvalidByFailedBuild

    PostBuildProjectStatus -> IO PostBuildProjectStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PostBuildProjectStatus
currentBuildStatus
    where
      displayPackageIdSet :: PackagesUpToDate -> String
displayPackageIdSet = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String)
-> (PackagesUpToDate -> [String]) -> PackagesUpToDate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId -> String) -> [UnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> String
forall a. Pretty a => a -> String
prettyShow ([UnitId] -> [String])
-> (PackagesUpToDate -> [UnitId]) -> PackagesUpToDate -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackagesUpToDate -> [UnitId]
forall a. Set a -> [a]
Set.toList

-- | Helper for reading the cache file.
--
-- This determines the type and format of the binary cache file.
readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate
readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate
readPackagesUpToDateCacheFile DistDirLayout{String -> String
distProjectCacheFile :: DistDirLayout -> String -> String
distProjectCacheFile :: String -> String
distProjectCacheFile} =
  PackagesUpToDate -> IO PackagesUpToDate -> IO PackagesUpToDate
forall a. a -> IO a -> IO a
handleDoesNotExist PackagesUpToDate
forall a. Set a
Set.empty (IO PackagesUpToDate -> IO PackagesUpToDate)
-> IO PackagesUpToDate -> IO PackagesUpToDate
forall a b. (a -> b) -> a -> b
$
    IO (Either String PackagesUpToDate) -> IO PackagesUpToDate
forall {a} {a}. IO (Either a (Set a)) -> IO (Set a)
handleDecodeFailure (IO (Either String PackagesUpToDate) -> IO PackagesUpToDate)
-> IO (Either String PackagesUpToDate) -> IO PackagesUpToDate
forall a b. (a -> b) -> a -> b
$
      String
-> IOMode
-> (Handle -> IO (Either String PackagesUpToDate))
-> IO (Either String PackagesUpToDate)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (String -> String
distProjectCacheFile String
"up-to-date") IOMode
ReadMode ((Handle -> IO (Either String PackagesUpToDate))
 -> IO (Either String PackagesUpToDate))
-> (Handle -> IO (Either String PackagesUpToDate))
-> IO (Either String PackagesUpToDate)
forall a b. (a -> b) -> a -> b
$ \Handle
hnd ->
        ByteString -> IO (Either String PackagesUpToDate)
forall a. Binary a => ByteString -> IO (Either String a)
Binary.decodeOrFailIO (ByteString -> IO (Either String PackagesUpToDate))
-> IO ByteString -> IO (Either String PackagesUpToDate)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO ByteString
BS.hGetContents Handle
hnd
  where
    handleDecodeFailure :: IO (Either a (Set a)) -> IO (Set a)
handleDecodeFailure = (Either a (Set a) -> Set a) -> IO (Either a (Set a)) -> IO (Set a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Set a) -> (Set a -> Set a) -> Either a (Set a) -> Set a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Set a -> a -> Set a
forall a b. a -> b -> a
const Set a
forall a. Set a
Set.empty) Set a -> Set a
forall a. a -> a
id)

-- | Helper for writing the package up-to-date cache file.
--
-- This determines the type and format of the binary cache file.
writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO ()
writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO ()
writePackagesUpToDateCacheFile DistDirLayout{String -> String
distProjectCacheFile :: DistDirLayout -> String -> String
distProjectCacheFile :: String -> String
distProjectCacheFile} PackagesUpToDate
upToDate =
  String -> ByteString -> IO ()
writeFileAtomic (String -> String
distProjectCacheFile String
"up-to-date") (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
    PackagesUpToDate -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode PackagesUpToDate
upToDate

-- | Prepare a package environment that includes all the library dependencies
-- for a plan.
--
-- When running cabal new-exec, we want to set things up so that the compiler
-- can find all the right packages (and nothing else). This function is
-- intended to do that work. It takes a location where it can write files
-- temporarily, in case the compiler wants to learn this information via the
-- filesystem, and returns any environment variable overrides the compiler
-- needs.
createPackageEnvironment
  :: Verbosity
  -> FilePath
  -> ElaboratedInstallPlan
  -> ElaboratedSharedConfig
  -> PostBuildProjectStatus
  -> IO [(String, Maybe String)]
createPackageEnvironment :: Verbosity
-> String
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> PostBuildProjectStatus
-> IO [(String, Maybe String)]
createPackageEnvironment
  Verbosity
verbosity
  String
path
  ElaboratedInstallPlan
elaboratedPlan
  ElaboratedSharedConfig
elaboratedShared
  PostBuildProjectStatus
buildStatus
    | Compiler -> CompilerFlavor
compilerFlavor (ElaboratedSharedConfig -> Compiler
pkgConfigCompiler ElaboratedSharedConfig
elaboratedShared) CompilerFlavor -> CompilerFlavor -> Bool
forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC =
        do
          Maybe String
envFileM <-
            String
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> PostBuildProjectStatus
-> IO (Maybe String)
writePlanGhcEnvironment
              String
path
              ElaboratedInstallPlan
elaboratedPlan
              ElaboratedSharedConfig
elaboratedShared
              PostBuildProjectStatus
buildStatus
          case Maybe String
envFileM of
            Just String
envFile -> [(String, Maybe String)] -> IO [(String, Maybe String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String
"GHC_ENVIRONMENT", String -> Maybe String
forall a. a -> Maybe a
Just String
envFile)]
            Maybe String
Nothing -> do
              Verbosity -> String -> IO ()
warn Verbosity
verbosity String
"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"
              [(String, Maybe String)] -> IO [(String, Maybe String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Bool
otherwise =
        do
          Verbosity -> String -> IO ()
warn Verbosity
verbosity String
"package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail"
          [(String, Maybe String)] -> IO [(String, Maybe String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- Writing .ghc.environment files
--

writePlanGhcEnvironment
  :: FilePath
  -> ElaboratedInstallPlan
  -> ElaboratedSharedConfig
  -> PostBuildProjectStatus
  -> IO (Maybe FilePath)
writePlanGhcEnvironment :: String
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> PostBuildProjectStatus
-> IO (Maybe String)
writePlanGhcEnvironment
  String
path
  ElaboratedInstallPlan
elaboratedInstallPlan
  ElaboratedSharedConfig
    { pkgConfigCompiler :: ElaboratedSharedConfig -> Compiler
pkgConfigCompiler = Compiler
compiler
    , pkgConfigPlatform :: ElaboratedSharedConfig -> Platform
pkgConfigPlatform = Platform
platform
    }
  PostBuildProjectStatus
postBuildStatus
    | Compiler -> CompilerFlavor
compilerFlavor Compiler
compiler CompilerFlavor -> CompilerFlavor -> Bool
forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC
    , GhcImplInfo -> Bool
supportsPkgEnvFiles (Compiler -> GhcImplInfo
getImplInfo Compiler
compiler) =
        -- TODO: check ghcjs compat
        (String -> Maybe String) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just (IO String -> IO (Maybe String)) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
          String
-> Platform
-> Version
-> [GhcEnvironmentFileEntry String]
-> IO String
writeGhcEnvironmentFile
            String
path
            Platform
platform
            (Compiler -> Version
compilerVersion Compiler
compiler)
            ( String
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [GhcEnvironmentFileEntry String]
renderGhcEnvironmentFile
                String
path
                ElaboratedInstallPlan
elaboratedInstallPlan
                PostBuildProjectStatus
postBuildStatus
            )
-- TODO: [required eventually] support for writing user-wide package
-- environments, e.g. like a global project, but we would not put the
-- env file in the home dir, rather it lives under ~/.ghc/

writePlanGhcEnvironment String
_ ElaboratedInstallPlan
_ ElaboratedSharedConfig
_ PostBuildProjectStatus
_ = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

renderGhcEnvironmentFile
  :: FilePath
  -> ElaboratedInstallPlan
  -> PostBuildProjectStatus
  -> [GhcEnvironmentFileEntry FilePath]
renderGhcEnvironmentFile :: String
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [GhcEnvironmentFileEntry String]
renderGhcEnvironmentFile
  String
projectRootDir
  ElaboratedInstallPlan
elaboratedInstallPlan
  PostBuildProjectStatus
postBuildStatus =
    GhcEnvironmentFileEntry String
forall {fp}. GhcEnvironmentFileEntry fp
headerComment
      GhcEnvironmentFileEntry String
-> [GhcEnvironmentFileEntry String]
-> [GhcEnvironmentFileEntry String]
forall a. a -> [a] -> [a]
: PackageDBStackCWD -> [UnitId] -> [GhcEnvironmentFileEntry String]
forall fp.
PackageDBStackX fp -> [UnitId] -> [GhcEnvironmentFileEntry fp]
simpleGhcEnvironmentFile PackageDBStackCWD
packageDBs [UnitId]
unitIds
    where
      headerComment :: GhcEnvironmentFileEntry fp
headerComment =
        String -> GhcEnvironmentFileEntry fp
forall fp. String -> GhcEnvironmentFileEntry fp
GhcEnvFileComment (String -> GhcEnvironmentFileEntry fp)
-> String -> GhcEnvironmentFileEntry fp
forall a b. (a -> b) -> a -> b
$
          String
"This is a GHC environment file written by cabal. This means you can\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"run ghc or ghci and get the environment of the project as a whole.\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"But you still need to use cabal repl $target to get the environment\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"of specific components (libs, exes, tests etc) because each one can\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"have its own source dirs, cpp flags etc.\n\n"
      unitIds :: [UnitId]
unitIds = PostBuildProjectStatus -> [UnitId]
selectGhcEnvironmentFileLibraries PostBuildProjectStatus
postBuildStatus
      packageDBs :: PackageDBStackCWD
packageDBs =
        String -> PackageDBStackCWD -> PackageDBStackCWD
relativePackageDBPaths String
projectRootDir (PackageDBStackCWD -> PackageDBStackCWD)
-> PackageDBStackCWD -> PackageDBStackCWD
forall a b. (a -> b) -> a -> b
$
          ElaboratedInstallPlan -> PackageDBStackCWD
selectGhcEnvironmentFilePackageDbs ElaboratedInstallPlan
elaboratedInstallPlan

argsEquivalentOfGhcEnvironmentFile
  :: Compiler
  -> DistDirLayout
  -> ElaboratedInstallPlan
  -> PostBuildProjectStatus
  -> [String]
argsEquivalentOfGhcEnvironmentFile :: Compiler
-> DistDirLayout
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [String]
argsEquivalentOfGhcEnvironmentFile Compiler
compiler =
  case Compiler -> CompilerId
compilerId Compiler
compiler of
    CompilerId CompilerFlavor
GHC Version
_ -> DistDirLayout
-> ElaboratedInstallPlan -> PostBuildProjectStatus -> [String]
argsEquivalentOfGhcEnvironmentFileGhc
    CompilerId CompilerFlavor
GHCJS Version
_ -> DistDirLayout
-> ElaboratedInstallPlan -> PostBuildProjectStatus -> [String]
argsEquivalentOfGhcEnvironmentFileGhc
    CompilerId CompilerFlavor
_ Version
_ -> String
-> DistDirLayout
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [String]
forall a. HasCallStack => String -> a
error String
"Only GHC and GHCJS are supported"

-- TODO remove this when we drop support for non-.ghc.env ghc
argsEquivalentOfGhcEnvironmentFileGhc
  :: DistDirLayout
  -> ElaboratedInstallPlan
  -> PostBuildProjectStatus
  -> [String]
argsEquivalentOfGhcEnvironmentFileGhc :: DistDirLayout
-> ElaboratedInstallPlan -> PostBuildProjectStatus -> [String]
argsEquivalentOfGhcEnvironmentFileGhc
  DistDirLayout
distDirLayout
  ElaboratedInstallPlan
elaboratedInstallPlan
  PostBuildProjectStatus
postBuildStatus =
    [String]
clearPackageDbStackFlag
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ PackageDBStackCWD -> [String]
packageDbArgsDb PackageDBStackCWD
packageDBs
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (UnitId -> [String]) -> [UnitId] -> [String]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap UnitId -> [String]
forall {a}. Pretty a => a -> [String]
packageIdFlag [UnitId]
packageIds
    where
      projectRootDir :: String
projectRootDir = DistDirLayout -> String
distProjectRootDirectory DistDirLayout
distDirLayout
      packageIds :: [UnitId]
packageIds = PostBuildProjectStatus -> [UnitId]
selectGhcEnvironmentFileLibraries PostBuildProjectStatus
postBuildStatus
      packageDBs :: PackageDBStackCWD
packageDBs =
        String -> PackageDBStackCWD -> PackageDBStackCWD
relativePackageDBPaths String
projectRootDir (PackageDBStackCWD -> PackageDBStackCWD)
-> PackageDBStackCWD -> PackageDBStackCWD
forall a b. (a -> b) -> a -> b
$
          ElaboratedInstallPlan -> PackageDBStackCWD
selectGhcEnvironmentFilePackageDbs ElaboratedInstallPlan
elaboratedInstallPlan
      -- TODO use proper flags? but packageDbArgsDb is private
      clearPackageDbStackFlag :: [String]
clearPackageDbStackFlag = [String
"-clear-package-db", String
"-global-package-db"]
      packageIdFlag :: a -> [String]
packageIdFlag a
uid = [String
"-package-id", a -> String
forall a. Pretty a => a -> String
prettyShow a
uid]

-- We're producing an environment for users to use in ghci, so of course
-- that means libraries only (can't put exes into the ghc package env!).
-- The library environment should be /consistent/ with the environment
-- that each of the packages in the project use (ie same lib versions).
-- So that means all the normal library dependencies of all the things
-- in the project (including deps of exes that are local to the project).
-- We do not however want to include the dependencies of Setup.hs scripts,
-- since these are generally uninteresting but also they need not in
-- general be consistent with the library versions that packages local to
-- the project use (recall that Setup.hs script's deps can be picked
-- independently of other packages in the project).
--
-- So, our strategy is as follows:
--
-- produce a dependency graph of all the packages in the install plan,
-- but only consider normal library deps as edges in the graph. Thus we
-- exclude the dependencies on Setup.hs scripts (in the case of
-- per-component granularity) or of Setup.hs scripts (in the case of
-- per-package granularity). Then take a dependency closure, using as
-- roots all the packages/components local to the project. This will
-- exclude Setup scripts and their dependencies.
--
-- Note: this algorithm will have to be adapted if/when the install plan
-- is extended to cover multiple compilers at once, and may also have to
-- change if we start to treat unshared deps of test suites in a similar
-- way to how we treat Setup.hs script deps (ie being able to pick them
-- independently).
--
-- Since we had to use all the local packages, including exes, (as roots
-- to find the libs) then those exes still end up in our list so we have
-- to filter them out at the end.
--
selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId]
selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId]
selectGhcEnvironmentFileLibraries PostBuildProjectStatus{PackagesUpToDate
Graph (Node UnitId ElaboratedPlanPackage)
packagesDefinitelyUpToDate :: PostBuildProjectStatus -> PackagesUpToDate
packagesProbablyUpToDate :: PostBuildProjectStatus -> PackagesUpToDate
packagesOutOfDate :: PostBuildProjectStatus -> PackagesUpToDate
packagesInvalidByChangedLibDeps :: PostBuildProjectStatus -> PackagesUpToDate
packagesInvalidByFailedBuild :: PostBuildProjectStatus -> PackagesUpToDate
packagesLibDepGraph :: PostBuildProjectStatus -> Graph (Node UnitId ElaboratedPlanPackage)
packagesBuildLocal :: PostBuildProjectStatus -> PackagesUpToDate
packagesBuildInplace :: PostBuildProjectStatus -> PackagesUpToDate
packagesAlreadyInStore :: PostBuildProjectStatus -> PackagesUpToDate
packagesDefinitelyUpToDate :: PackagesUpToDate
packagesProbablyUpToDate :: PackagesUpToDate
packagesOutOfDate :: PackagesUpToDate
packagesInvalidByChangedLibDeps :: PackagesUpToDate
packagesInvalidByFailedBuild :: PackagesUpToDate
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
packagesBuildLocal :: PackagesUpToDate
packagesBuildInplace :: PackagesUpToDate
packagesAlreadyInStore :: PackagesUpToDate
..} =
  case Graph (Node UnitId ElaboratedPlanPackage)
-> [Key (Node UnitId ElaboratedPlanPackage)]
-> Maybe [Node UnitId ElaboratedPlanPackage]
forall a. Graph a -> [Key a] -> Maybe [a]
Graph.closure Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph (PackagesUpToDate -> [UnitId]
forall a. Set a -> [a]
Set.toList PackagesUpToDate
packagesBuildLocal) of
    Maybe [Node UnitId ElaboratedPlanPackage]
Nothing -> String -> [UnitId]
forall a. HasCallStack => String -> a
error String
"renderGhcEnvironmentFile: broken dep closure"
    Just [Node UnitId ElaboratedPlanPackage]
nodes ->
      [ UnitId
pkgid | Graph.N ElaboratedPlanPackage
pkg UnitId
pkgid [UnitId]
_ <- [Node UnitId ElaboratedPlanPackage]
nodes, ElaboratedPlanPackage -> Bool
forall {ipkg}.
GenericPlanPackage ipkg ElaboratedConfiguredPackage -> Bool
hasUpToDateLib ElaboratedPlanPackage
pkg
      ]
  where
    hasUpToDateLib :: GenericPlanPackage ipkg ElaboratedConfiguredPackage -> Bool
hasUpToDateLib GenericPlanPackage ipkg ElaboratedConfiguredPackage
planpkg = case GenericPlanPackage ipkg ElaboratedConfiguredPackage
planpkg of
      -- A pre-existing global lib
      InstallPlan.PreExisting ipkg
_ -> Bool
True
      -- A package in the store. Check it's a lib.
      InstallPlan.Installed ElaboratedConfiguredPackage
pkg -> ElaboratedConfiguredPackage -> Bool
elabRequiresRegistration ElaboratedConfiguredPackage
pkg
      -- A package we were installing this time, either destined for the store
      -- or just locally. Check it's a lib and that it is probably up to date.
      InstallPlan.Configured ElaboratedConfiguredPackage
pkg ->
        ElaboratedConfiguredPackage -> Bool
elabRequiresRegistration ElaboratedConfiguredPackage
pkg
          Bool -> Bool -> Bool
&& ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
pkg UnitId -> PackagesUpToDate -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` PackagesUpToDate
packagesProbablyUpToDate

selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStackCWD
selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStackCWD
selectGhcEnvironmentFilePackageDbs ElaboratedInstallPlan
elaboratedInstallPlan =
  -- If we have any inplace packages then their package db stack is the
  -- one we should use since it'll include the store + the local db but
  -- it's certainly possible to have no local inplace packages
  -- e.g. just "extra" packages coming from the store.
  case ([ElaboratedConfiguredPackage]
inplacePackages, [ElaboratedConfiguredPackage]
sourcePackages) of
    ([], [ElaboratedConfiguredPackage]
pkgs) -> [ElaboratedConfiguredPackage] -> PackageDBStackCWD
checkSamePackageDBs [ElaboratedConfiguredPackage]
pkgs
    ([ElaboratedConfiguredPackage]
pkgs, [ElaboratedConfiguredPackage]
_) -> [ElaboratedConfiguredPackage] -> PackageDBStackCWD
checkSamePackageDBs [ElaboratedConfiguredPackage]
pkgs
  where
    checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStackCWD
    checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStackCWD
checkSamePackageDBs [ElaboratedConfiguredPackage]
pkgs =
      case [PackageDBStackCWD] -> [PackageDBStackCWD]
forall a. Ord a => [a] -> [a]
ordNub ((ElaboratedConfiguredPackage -> PackageDBStackCWD)
-> [ElaboratedConfiguredPackage] -> [PackageDBStackCWD]
forall a b. (a -> b) -> [a] -> [b]
map ElaboratedConfiguredPackage -> PackageDBStackCWD
elabBuildPackageDBStack [ElaboratedConfiguredPackage]
pkgs) of
        [PackageDBStackCWD
packageDbs] -> PackageDBStackCWD
packageDbs
        [] -> []
        [PackageDBStackCWD]
_ ->
          String -> PackageDBStackCWD
forall a. HasCallStack => String -> a
error (String -> PackageDBStackCWD) -> String -> PackageDBStackCWD
forall a b. (a -> b) -> a -> b
$
            String
"renderGhcEnvironmentFile: packages with "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"different package db stacks"
    -- This should not happen at the moment but will happen as soon
    -- as we support projects where we build packages with different
    -- compilers, at which point we have to consider how to adapt
    -- this feature, e.g. write out multiple env files, one for each
    -- compiler / project profile.

    inplacePackages :: [ElaboratedConfiguredPackage]
    inplacePackages :: [ElaboratedConfiguredPackage]
inplacePackages =
      [ ElaboratedConfiguredPackage
srcpkg
      | ElaboratedConfiguredPackage
srcpkg <- [ElaboratedConfiguredPackage]
sourcePackages
      , BuildStyle -> Bool
isInplaceBuildStyle (ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
srcpkg)
      ]

    sourcePackages :: [ElaboratedConfiguredPackage]
    sourcePackages :: [ElaboratedConfiguredPackage]
sourcePackages =
      [ ElaboratedConfiguredPackage
srcpkg
      | ElaboratedPlanPackage
pkg <- ElaboratedInstallPlan -> [ElaboratedPlanPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
elaboratedInstallPlan
      , ElaboratedConfiguredPackage
srcpkg <- Maybe ElaboratedConfiguredPackage -> [ElaboratedConfiguredPackage]
forall a. Maybe a -> [a]
maybeToList (Maybe ElaboratedConfiguredPackage
 -> [ElaboratedConfiguredPackage])
-> Maybe ElaboratedConfiguredPackage
-> [ElaboratedConfiguredPackage]
forall a b. (a -> b) -> a -> b
$ case ElaboratedPlanPackage
pkg of
          InstallPlan.Configured ElaboratedConfiguredPackage
srcpkg -> ElaboratedConfiguredPackage -> Maybe ElaboratedConfiguredPackage
forall a. a -> Maybe a
Just ElaboratedConfiguredPackage
srcpkg
          InstallPlan.Installed ElaboratedConfiguredPackage
srcpkg -> ElaboratedConfiguredPackage -> Maybe ElaboratedConfiguredPackage
forall a. a -> Maybe a
Just ElaboratedConfiguredPackage
srcpkg
          InstallPlan.PreExisting InstalledPackageInfo
_ -> Maybe ElaboratedConfiguredPackage
forall a. Maybe a
Nothing
      ]

relativePackageDBPaths :: FilePath -> PackageDBStackCWD -> PackageDBStackCWD
relativePackageDBPaths :: String -> PackageDBStackCWD -> PackageDBStackCWD
relativePackageDBPaths String
relroot = (PackageDBX String -> PackageDBX String)
-> PackageDBStackCWD -> PackageDBStackCWD
forall a b. (a -> b) -> [a] -> [b]
map (String -> PackageDBX String -> PackageDBX String
relativePackageDBPath String
relroot)

relativePackageDBPath :: FilePath -> PackageDBCWD -> PackageDBCWD
relativePackageDBPath :: String -> PackageDBX String -> PackageDBX String
relativePackageDBPath String
relroot PackageDBX String
pkgdb =
  case PackageDBX String
pkgdb of
    PackageDBX String
GlobalPackageDB -> PackageDBX String
forall fp. PackageDBX fp
GlobalPackageDB
    PackageDBX String
UserPackageDB -> PackageDBX String
forall fp. PackageDBX fp
UserPackageDB
    SpecificPackageDB String
path -> String -> PackageDBX String
forall fp. fp -> PackageDBX fp
SpecificPackageDB String
relpath
      where
        relpath :: String
relpath = String -> String -> String
makeRelative (String -> String
normalise String
relroot) String
path