{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns,
DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,
ScopedTypeVariables #-}
module Distribution.Client.ProjectPlanOutput (
writePlanExternalRepresentation,
PostBuildProjectStatus(..),
updatePostBuildProjectStatus,
createPackageEnvironment,
writePlanGhcEnvironment,
argsEquivalentOfGhcEnvironmentFile,
) where
import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.ProjectBuilding.Types
import Distribution.Client.DistDirLayout
import Distribution.Client.Types.Repo (Repo(..), RemoteRepo(..))
import Distribution.Client.Types.PackageLocation (PackageLocation(..))
import Distribution.Client.Types.ConfiguredId (confInstId)
import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..))
import Distribution.Client.HashValue (showHashValue, hashValue)
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 Distribution.Package
import Distribution.System
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.PackageDescription as PD
import Distribution.Compiler (CompilerFlavor(GHC, GHCJS))
import Distribution.Simple.Compiler
( PackageDBStack, PackageDB(..)
, compilerVersion, compilerFlavor, showCompilerId
, compilerId, CompilerId(..), Compiler )
import Distribution.Simple.GHC
( getImplInfo, GhcImplInfo(supportsPkgEnvFiles)
, GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile
, writeGhcEnvironmentFile )
import Distribution.Simple.BuildPaths
( dllExtension, exeExtension, buildInfoPref )
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Graph, Node)
import qualified Distribution.Compat.Binary as Binary
import Distribution.Simple.Utils
import Distribution.Types.Version
( mkVersion )
import Distribution.Verbosity
import Prelude ()
import Distribution.Client.Compat.Prelude
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Builder as BB
import System.FilePath
import System.IO
import Distribution.Simple.Program.GHC (packageDbArgsDb)
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") forall a b. (a -> b) -> a -> b
$
Builder -> ByteString
BB.toLazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Builder
J.encodeToBuilder
forall a b. (a -> b) -> a -> b
$ DistDirLayout
-> ElaboratedInstallPlan -> ElaboratedSharedConfig -> Value
encodePlanAsJson DistDirLayout
distDirLayout ElaboratedInstallPlan
elaboratedInstallPlan ElaboratedSharedConfig
elaboratedSharedConfig
encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value
encodePlanAsJson :: DistDirLayout
-> ElaboratedInstallPlan -> ElaboratedSharedConfig -> Value
encodePlanAsJson DistDirLayout
distDirLayout ElaboratedInstallPlan
elaboratedInstallPlan ElaboratedSharedConfig
elaboratedSharedConfig =
[Pair] -> Value
J.object [ String
"cabal-version" forall v. ToJSON v => String -> v -> Pair
J..= forall a. Pretty a => a -> Value
jdisplay Version
cabalInstallVersion
, String
"cabal-lib-version" forall v. ToJSON v => String -> v -> Pair
J..= forall a. Pretty a => a -> Value
jdisplay Version
cabalVersion
, String
"compiler-id" forall v. ToJSON v => String -> v -> Pair
J..= (String -> Value
J.String forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compiler -> String
showCompilerId forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedSharedConfig -> Compiler
pkgConfigCompiler)
ElaboratedSharedConfig
elaboratedSharedConfig
, String
"os" forall v. ToJSON v => String -> v -> Pair
J..= forall a. Pretty a => a -> Value
jdisplay OS
os
, String
"arch" forall v. ToJSON v => String -> v -> Pair
J..= forall a. Pretty a => a -> Value
jdisplay Arch
arch
, String
"install-plan" 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 = forall a b. (a -> b) -> [a] -> [b]
map ElaboratedPlanPackage -> Value
planPackageToJ forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
installedPackageInfoToJ :: InstalledPackageInfo -> J.Value
installedPackageInfoToJ :: InstalledPackageInfo -> Value
installedPackageInfoToJ InstalledPackageInfo
ipi =
[Pair] -> Value
J.object
[ String
"type" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"pre-existing"
, String
"id" forall v. ToJSON v => String -> v -> Pair
J..= (forall a. Pretty a => a -> Value
jdisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId) InstalledPackageInfo
ipi
, String
"pkg-name" forall v. ToJSON v => String -> v -> Pair
J..= (forall a. Pretty a => a -> Value
jdisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) InstalledPackageInfo
ipi
, String
"pkg-version" forall v. ToJSON v => String -> v -> Pair
J..= (forall a. Pretty a => a -> Value
jdisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
pkgVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) InstalledPackageInfo
ipi
, String
"depends" forall v. ToJSON v => String -> v -> Pair
J..= forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Value
jdisplay (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 forall a b. (a -> b) -> a -> b
$
[ String
"type" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (if Bool
isInstalled then String
"installed"
else String
"configured")
, String
"id" forall v. ToJSON v => String -> v -> Pair
J..= (forall a. Pretty a => a -> Value
jdisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId) ElaboratedConfiguredPackage
elab
, String
"pkg-name" forall v. ToJSON v => String -> v -> Pair
J..= (forall a. Pretty a => a -> Value
jdisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) ElaboratedConfiguredPackage
elab
, String
"pkg-version" forall v. ToJSON v => String -> v -> Pair
J..= (forall a. Pretty a => a -> Value
jdisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
pkgVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) ElaboratedConfiguredPackage
elab
, String
"flags" forall v. ToJSON v => String -> v -> Pair
J..= [Pair] -> Value
J.object [ FlagName -> String
PD.unFlagName FlagName
fn 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" 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" forall v. ToJSON v => String -> v -> Pair
J..= PackageLocation (Maybe String) -> Value
packageLocationToJ (ElaboratedConfiguredPackage -> PackageLocation (Maybe String)
elabPkgSourceLocation ElaboratedConfiguredPackage
elab)
] forall a. [a] -> [a] -> [a]
++
[ String
"pkg-cabal-sha256" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (HashValue -> String
showHashValue HashValue
hash)
| Just HashValue
hash <- [ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> HashValue
hashValue (ElaboratedConfiguredPackage -> Maybe ByteString
elabPkgDescriptionOverride ElaboratedConfiguredPackage
elab) ] ] forall a. [a] -> [a] -> [a]
++
[ String
"pkg-src-sha256" 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] ] forall a. [a] -> [a] -> [a]
++
(case ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
elab of
BuildStyle
BuildInplaceOnly ->
[String
"dist-dir" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
dist_dir] forall a. [a] -> [a] -> [a]
++ [Pair
buildInfoFileLocation]
BuildStyle
BuildAndInstall ->
[]
) forall a. [a] -> [a] -> [a]
++
case ElaboratedConfiguredPackage -> ElaboratedPackageOrComponent
elabPkgOrComp ElaboratedConfiguredPackage
elab of
ElabPackage ElaboratedPackage
pkg ->
let components :: Value
components = [Pair] -> Value
J.object forall a b. (a -> b) -> a -> b
$
[ Component -> String
comp2str Component
c forall v. ToJSON v => String -> v -> Pair
J..= ([Pair] -> Value
J.object forall a b. (a -> b) -> a -> b
$
[ String
"depends" forall v. ToJSON v => String -> v -> Pair
J..= forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> Value
jdisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredId -> ComponentId
confInstId) [ConfiguredId]
ldeps
, String
"exe-depends" forall v. ToJSON v => String -> v -> Pair
J..= forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> Value
jdisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredId -> ComponentId
confInstId) [ConfiguredId]
edeps
] forall a. [a] -> [a] -> [a]
++
Component -> [Pair]
bin_file Component
c)
| (Component
c,([ConfiguredId]
ldeps,[ConfiguredId]
edeps))
<- forall a. ComponentDeps a -> [ComponentDep a]
ComponentDeps.toList forall a b. (a -> b) -> a -> b
$
forall a b.
(Monoid a, Monoid b) =>
ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b)
ComponentDeps.zip (ElaboratedPackage -> ComponentDeps [ConfiguredId]
pkgLibDependencies ElaboratedPackage
pkg)
(ElaboratedPackage -> ComponentDeps [ConfiguredId]
pkgExeDependencies ElaboratedPackage
pkg) ]
in [String
"components" forall v. ToJSON v => String -> v -> Pair
J..= Value
components]
ElabComponent ElaboratedComponent
comp ->
[String
"depends" forall v. ToJSON v => String -> v -> Pair
J..= forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> Value
jdisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredId -> ComponentId
confInstId) (ElaboratedConfiguredPackage -> [ConfiguredId]
elabLibDependencies ElaboratedConfiguredPackage
elab)
,String
"exe-depends" forall v. ToJSON v => String -> v -> Pair
J..= forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Value
jdisplay (ElaboratedConfiguredPackage -> [ComponentId]
elabExeDependencies ElaboratedConfiguredPackage
elab)
,String
"component-name" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (Component -> String
comp2str (ElaboratedComponent -> Component
compSolverName ElaboratedComponent
comp))
] forall a. [a] -> [a] -> [a]
++
Component -> [Pair]
bin_file (ElaboratedComponent -> Component
compSolverName ElaboratedComponent
comp)
where
buildInfoFileLocation :: J.Pair
buildInfoFileLocation :: Pair
buildInfoFileLocation
| ElaboratedConfiguredPackage -> Version
elabSetupScriptCliVersion ElaboratedConfiguredPackage
elab forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
3, Int
7, Int
0, Int
0]
= String
"build-info" forall v. ToJSON v => String -> v -> Pair
J..= Value
J.Null
| Bool
otherwise
= String
"build-info" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (String -> String
buildInfoPref 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" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"local"
, String
"path" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
local
]
LocalTarballPackage String
local ->
[Pair] -> Value
J.object [ String
"type" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"local-tar"
, String
"path" 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" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"remote-tar"
, String
"uri" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (forall a. Show a => a -> String
show URI
uri)
]
RepoTarballPackage Repo
repo PackageIdentifier
_ Maybe String
_ ->
[Pair] -> Value
J.object [ String
"type" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"repo-tar"
, String
"repo" forall v. ToJSON v => String -> v -> Pair
J..= Repo -> Value
repoToJ Repo
repo
]
RemoteSourceRepoPackage SourceRepoMaybe
srcRepo Maybe String
_ ->
[Pair] -> Value
J.object [ String
"type" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"source-repo"
, String
"source-repo" 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
repoLocalDir :: Repo -> String
repoLocal :: Repo -> LocalRepo
repoLocalDir :: String
repoLocal :: LocalRepo
..} ->
[Pair] -> Value
J.object [ String
"type" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"local-repo-no-index"
, String
"path" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
repoLocalDir
]
RepoRemote{String
RemoteRepo
repoRemote :: Repo -> RemoteRepo
repoLocalDir :: String
repoRemote :: RemoteRepo
repoLocalDir :: Repo -> String
..} ->
[Pair] -> Value
J.object [ String
"type" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"remote-repo"
, String
"uri" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String (forall a. Show a => a -> String
show (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repoRemote))
]
RepoSecure{String
RemoteRepo
repoLocalDir :: String
repoRemote :: RemoteRepo
repoRemote :: Repo -> RemoteRepo
repoLocalDir :: Repo -> String
..} ->
[Pair] -> Value
J.object [ String
"type" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
"secure-repo"
, String
"uri" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.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
srpCommand :: forall (f :: * -> *). SourceRepositoryPackage f -> [String]
srpSubdir :: forall (f :: * -> *). SourceRepositoryPackage f -> f String
srpBranch :: forall (f :: * -> *). SourceRepositoryPackage f -> Maybe String
srpTag :: forall (f :: * -> *). SourceRepositoryPackage f -> Maybe String
srpLocation :: forall (f :: * -> *). SourceRepositoryPackage f -> String
srpType :: forall (f :: * -> *). SourceRepositoryPackage f -> RepoType
srpCommand :: [String]
srpSubdir :: Maybe String
srpBranch :: Maybe String
srpTag :: Maybe String
srpLocation :: String
srpType :: RepoType
..} =
[Pair] -> Value
J.object forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Value
J.Null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
[ String
"type" forall v. ToJSON v => String -> v -> Pair
J..= forall a. Pretty a => a -> Value
jdisplay RepoType
srpType
, String
"location" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
srpLocation
, String
"branch" forall v. ToJSON v => String -> v -> Pair
J..= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Value
J.String Maybe String
srpBranch
, String
"tag" forall v. ToJSON v => String -> v -> Pair
J..= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Value
J.String Maybe String
srpTag
, String
"subdir" forall v. ToJSON v => String -> v -> Pair
J..= 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 -> forall {p}. Pretty p => p -> [Pair]
bin_file' UnqualComponentName
s
ComponentDeps.ComponentTest UnqualComponentName
s -> forall {p}. Pretty p => p -> [Pair]
bin_file' UnqualComponentName
s
ComponentDeps.ComponentBench UnqualComponentName
s -> forall {p}. Pretty p => p -> [Pair]
bin_file' UnqualComponentName
s
ComponentDeps.ComponentFLib UnqualComponentName
s -> forall a. (Pretty a, Show a) => a -> [Pair]
flib_file' UnqualComponentName
s
Component
_ -> []
bin_file' :: p -> [Pair]
bin_file' p
s =
[String
"bin-file" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
bin]
where
bin :: String
bin = if ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
elab forall a. Eq a => a -> a -> Bool
== BuildStyle
BuildInplaceOnly
then String
dist_dir String -> String -> String
</> String
"build" String -> String -> String
</> forall a. Pretty a => a -> String
prettyShow p
s String -> String -> String
</> forall a. Pretty a => a -> String
prettyShow p
s String -> String -> String
<.> Platform -> String
exeExtension Platform
plat
else forall dir. InstallDirs dir -> dir
InstallDirs.bindir (ElaboratedConfiguredPackage -> InstallDirs String
elabInstallDirs ElaboratedConfiguredPackage
elab) String -> String -> 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" forall v. ToJSON v => String -> v -> Pair
J..= String -> Value
J.String String
bin]
where
bin :: String
bin = if ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
elab forall a. Eq a => a -> a -> Bool
== BuildStyle
BuildInplaceOnly
then String
dist_dir String -> String -> String
</> String
"build" String -> String -> String
</> forall a. Pretty a => a -> String
prettyShow a
s String -> String -> String
</> (String
"lib" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow a
s) String -> String -> String
<.> Platform -> String
dllExtension Platform
plat
else forall dir. InstallDirs dir -> dir
InstallDirs.bindir (ElaboratedConfiguredPackage -> InstallDirs String
elabInstallDirs ElaboratedConfiguredPackage
elab) String -> String -> String
</> (String
"lib" forall a. [a] -> [a] -> [a]
++ 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 = forall a. Pretty a => a -> String
prettyShow
style2str :: Bool -> BuildStyle -> String
style2str :: Bool -> BuildStyle -> String
style2str Bool
True BuildStyle
_ = String
"local"
style2str Bool
False BuildStyle
BuildInplaceOnly = String
"inplace"
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> String
prettyShow
type PackageIdSet = Set UnitId
type PackagesUpToDate = PackageIdSet
data PostBuildProjectStatus = PostBuildProjectStatus {
PostBuildProjectStatus -> PackagesUpToDate
packagesDefinitelyUpToDate :: PackageIdSet,
PostBuildProjectStatus -> PackagesUpToDate
packagesProbablyUpToDate :: PackageIdSet,
PostBuildProjectStatus -> PackagesUpToDate
packagesOutOfDate :: PackageIdSet,
PostBuildProjectStatus -> PackagesUpToDate
packagesInvalidByChangedLibDeps :: PackageIdSet,
PostBuildProjectStatus -> PackagesUpToDate
packagesInvalidByFailedBuild :: PackageIdSet,
PostBuildProjectStatus -> Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage),
PostBuildProjectStatus -> PackagesUpToDate
packagesBuildLocal :: PackageIdSet,
PostBuildProjectStatus -> PackagesUpToDate
packagesBuildInplace :: PackageIdSet,
PostBuildProjectStatus -> PackagesUpToDate
packagesAlreadyInStore :: PackageIdSet
}
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,
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
forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
PackagesUpToDate
packagesSuccessfulPostBuild
packagesProbablyUpToDate :: PackagesUpToDate
packagesProbablyUpToDate =
PackagesUpToDate
packagesDefinitelyUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
(PackagesUpToDate
previousPackagesUpToDate' forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` PackagesUpToDate
packagesOutOfDatePreBuild)
packagesOutOfDate :: PackagesUpToDate
packagesOutOfDate =
PackagesUpToDate
packagesOutOfDatePreBuild forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` PackagesUpToDate
packagesSuccessfulPostBuild
packagesInvalidByChangedLibDeps :: PackagesUpToDate
packagesInvalidByChangedLibDeps =
PackagesUpToDate
packagesDepOnChangedLib forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` PackagesUpToDate
packagesSuccessfulPostBuild
packagesInvalidByFailedBuild :: PackagesUpToDate
packagesInvalidByFailedBuild =
PackagesUpToDate
packagesFailurePostBuild
previousPackagesUpToDate' :: PackagesUpToDate
previousPackagesUpToDate' =
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection
PackagesUpToDate
previousPackagesUpToDate
(forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> PackagesUpToDate
InstallPlan.keysSet ElaboratedInstallPlan
plan)
packagesUpToDatePreBuild :: PackagesUpToDate
packagesUpToDatePreBuild =
forall a. (a -> Bool) -> Set a -> Set a
Set.filter
(\UnitId
ipkgid -> Bool -> Bool
not (Bool -> UnitId -> Bool
lookupBuildStatusRequiresBuild Bool
True UnitId
ipkgid))
(forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> PackagesUpToDate
InstallPlan.keysSet ElaboratedInstallPlan
plan)
packagesOutOfDatePreBuild :: PackagesUpToDate
packagesOutOfDatePreBuild =
forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId forall a b. (a -> b) -> a -> b
$
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> [UnitId] -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.reverseDependencyClosure ElaboratedInstallPlan
plan
[ UnitId
ipkgid
| ElaboratedPlanPackage
pkg <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
plan
, let ipkgid :: UnitId
ipkgid = forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedPlanPackage
pkg
, Bool -> UnitId -> Bool
lookupBuildStatusRequiresBuild Bool
False UnitId
ipkgid
]
packagesSuccessfulPostBuild :: PackagesUpToDate
packagesSuccessfulPostBuild =
forall a. Ord a => [a] -> Set a
Set.fromList
[ UnitId
ikgid | (UnitId
ikgid, Right BuildResult
_) <- forall k a. Map k a -> [(k, a)]
Map.toList BuildOutcomes
buildOutcomes ]
packagesFailurePostBuild :: PackagesUpToDate
packagesFailurePostBuild =
forall a. Ord a => [a] -> Set a
Set.fromList
[ UnitId
ikgid
| (UnitId
ikgid, Left BuildFailure
failure) <- 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
]
packagesDepOnChangedLib :: PackagesUpToDate
packagesDepOnChangedLib =
forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. IsNode a => a -> Key a
Graph.nodeKey forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"packagesBuildStatusAfterBuild: broken dep closure") forall a b. (a -> b) -> a -> b
$
forall a. Graph a -> [Key a] -> Maybe [a]
Graph.revClosure Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph
( forall k a. Map k a -> [k]
Map.keys
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry BuildStatus -> BuildOutcome -> Bool
buildAttempted)
forall a b. (a -> b) -> a -> b
$ 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
)
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph =
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList
[ forall k a. a -> k -> [k] -> Node k a
Graph.N ElaboratedPlanPackage
pkg (forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedPlanPackage
pkg) [UnitId]
libdeps
| ElaboratedPlanPackage
pkg <- 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 -> 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 = forall a b. (a -> b) -> [a] -> [b]
map (ComponentId -> UnitId
newSimpleUnitId forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredId -> ComponentId
confInstId) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedConfiguredPackage -> [ConfiguredId]
elabLibDependencies
buildAttempted :: BuildStatus -> BuildOutcome -> Bool
buildAttempted :: BuildStatus -> BuildOutcome -> Bool
buildAttempted BuildStatus
buildStatus BuildOutcome
_buildOutcome
| Bool -> Bool
not (BuildStatus -> Bool
buildStatusRequiresBuild BuildStatus
buildStatus)
= Bool
False
buildAttempted BuildStatus
_ (Left BuildFailure {BuildFailureReason
buildFailureReason :: BuildFailureReason
buildFailureReason :: BuildFailure -> BuildFailureReason
buildFailureReason})
| DependentFailed PackageIdentifier
_ <- BuildFailureReason
buildFailureReason
= Bool
False
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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
ipkgid BuildStatusMap
pkgBuildStatus of
Maybe BuildStatus
Nothing -> Bool
def
Just BuildStatus
buildStatus -> BuildStatus -> Bool
buildStatusRequiresBuild BuildStatus
buildStatus
packagesBuildLocal :: Set UnitId
packagesBuildLocal :: PackagesUpToDate
packagesBuildLocal =
(ElaboratedPlanPackage -> Bool) -> PackagesUpToDate
selectPlanPackageIdSet 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 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 -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
srcpkg
forall a. Eq a => a -> a -> Bool
== BuildStyle
BuildInplaceOnly
packagesAlreadyInStore :: Set UnitId
packagesAlreadyInStore :: PackagesUpToDate
packagesAlreadyInStore =
(ElaboratedPlanPackage -> Bool) -> PackagesUpToDate
selectPlanPackageIdSet 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 = forall k a. Map k a -> Set k
Map.keysSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ElaboratedPlanPackage -> Bool
p
forall a b. (a -> b) -> a -> b
$ 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
PackagesUpToDate
previousUpToDate <- DistDirLayout -> IO PackagesUpToDate
readPackagesUpToDateCacheFile DistDirLayout
distDirLayout
let currentBuildStatus :: PostBuildProjectStatus
currentBuildStatus@PostBuildProjectStatus{Graph (Node UnitId ElaboratedPlanPackage)
PackagesUpToDate
packagesAlreadyInStore :: PackagesUpToDate
packagesBuildInplace :: PackagesUpToDate
packagesBuildLocal :: PackagesUpToDate
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
packagesInvalidByFailedBuild :: PackagesUpToDate
packagesInvalidByChangedLibDeps :: PackagesUpToDate
packagesOutOfDate :: PackagesUpToDate
packagesProbablyUpToDate :: PackagesUpToDate
packagesDefinitelyUpToDate :: PackagesUpToDate
packagesAlreadyInStore :: PostBuildProjectStatus -> PackagesUpToDate
packagesBuildInplace :: PostBuildProjectStatus -> PackagesUpToDate
packagesBuildLocal :: PostBuildProjectStatus -> PackagesUpToDate
packagesLibDepGraph :: PostBuildProjectStatus -> Graph (Node UnitId ElaboratedPlanPackage)
packagesInvalidByFailedBuild :: PostBuildProjectStatus -> PackagesUpToDate
packagesInvalidByChangedLibDeps :: PostBuildProjectStatus -> PackagesUpToDate
packagesOutOfDate :: PostBuildProjectStatus -> PackagesUpToDate
packagesProbablyUpToDate :: PostBuildProjectStatus -> PackagesUpToDate
packagesDefinitelyUpToDate :: PostBuildProjectStatus -> 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
Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String
"packages definitely up to date: "
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet (PackagesUpToDate
packagesDefinitelyUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` PackagesUpToDate
packagesBuildInplace)
Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String
"packages previously probably up to date: "
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet (PackagesUpToDate
previousUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` PackagesUpToDate
packagesBuildInplace)
Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String
"packages now probably up to date: "
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet (PackagesUpToDate
packagesProbablyUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` PackagesUpToDate
packagesBuildInplace)
Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String
"packages newly up to date: "
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet (PackagesUpToDate
packagesDefinitelyUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` PackagesUpToDate
previousUpToDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` PackagesUpToDate
packagesBuildInplace)
Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String
"packages out to date: "
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet (PackagesUpToDate
packagesOutOfDate
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` PackagesUpToDate
packagesBuildInplace)
Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String
"packages invalid due to dep change: "
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet PackagesUpToDate
packagesInvalidByChangedLibDeps
Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String
"packages invalid due to build failure: "
forall a. [a] -> [a] -> [a]
++ PackagesUpToDate -> String
displayPackageIdSet PackagesUpToDate
packagesInvalidByFailedBuild
forall (m :: * -> *) a. Monad m => a -> m a
return PostBuildProjectStatus
currentBuildStatus
where
displayPackageIdSet :: PackagesUpToDate -> String
displayPackageIdSet = forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList
readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate
readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate
readPackagesUpToDateCacheFile DistDirLayout{String -> String
distProjectCacheFile :: String -> String
distProjectCacheFile :: DistDirLayout -> String -> String
distProjectCacheFile} =
forall a. a -> IO a -> IO a
handleDoesNotExist forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$
forall {a} {a}. IO (Either a (Set a)) -> IO (Set a)
handleDecodeFailure forall a b. (a -> b) -> a -> b
$
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (String -> String
distProjectCacheFile String
"up-to-date") IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
hnd ->
forall a. Binary a => ByteString -> IO (Either String a)
Binary.decodeOrFailIO 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Set a
Set.empty) forall a. a -> a
id)
writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO ()
writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO ()
writePackagesUpToDateCacheFile DistDirLayout{String -> String
distProjectCacheFile :: String -> String
distProjectCacheFile :: DistDirLayout -> String -> String
distProjectCacheFile} PackagesUpToDate
upToDate =
String -> ByteString -> IO ()
writeFileAtomic (String -> String
distProjectCacheFile String
"up-to-date") forall a b. (a -> b) -> a -> b
$
forall a. Binary a => a -> ByteString
Binary.encode PackagesUpToDate
upToDate
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) 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return [(String
"GHC_ENVIRONMENT", 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"
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"
forall (m :: * -> *) a. Monad m => a -> m a
return []
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 forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC
, GhcImplInfo -> Bool
supportsPkgEnvFiles (Compiler -> GhcImplInfo
getImplInfo Compiler
compiler)
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
-> Platform -> Version -> [GhcEnvironmentFileEntry] -> IO String
writeGhcEnvironmentFile
String
path
Platform
platform (Compiler -> Version
compilerVersion Compiler
compiler)
(String
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [GhcEnvironmentFileEntry]
renderGhcEnvironmentFile String
path
ElaboratedInstallPlan
elaboratedInstallPlan
PostBuildProjectStatus
postBuildStatus)
writePlanGhcEnvironment String
_ ElaboratedInstallPlan
_ ElaboratedSharedConfig
_ PostBuildProjectStatus
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
renderGhcEnvironmentFile :: FilePath
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [GhcEnvironmentFileEntry]
renderGhcEnvironmentFile :: String
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [GhcEnvironmentFileEntry]
renderGhcEnvironmentFile String
projectRootDir ElaboratedInstallPlan
elaboratedInstallPlan
PostBuildProjectStatus
postBuildStatus =
GhcEnvironmentFileEntry
headerComment
forall a. a -> [a] -> [a]
: PackageDBStack -> [UnitId] -> [GhcEnvironmentFileEntry]
simpleGhcEnvironmentFile PackageDBStack
packageDBs [UnitId]
unitIds
where
headerComment :: GhcEnvironmentFileEntry
headerComment =
String -> GhcEnvironmentFileEntry
GhcEnvFileComment
forall a b. (a -> b) -> a -> b
$ String
"This is a GHC environment file written by cabal. This means you can\n"
forall a. [a] -> [a] -> [a]
++ String
"run ghc or ghci and get the environment of the project as a whole.\n"
forall a. [a] -> [a] -> [a]
++ String
"But you still need to use cabal repl $target to get the environment\n"
forall a. [a] -> [a] -> [a]
++ String
"of specific components (libs, exes, tests etc) because each one can\n"
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 :: PackageDBStack
packageDBs = String -> PackageDBStack -> PackageDBStack
relativePackageDBPaths String
projectRootDir forall a b. (a -> b) -> a -> b
$
ElaboratedInstallPlan -> PackageDBStack
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
_ -> forall a. HasCallStack => String -> a
error String
"Only GHC and GHCJS are supported"
argsEquivalentOfGhcEnvironmentFileGhc
:: DistDirLayout
-> ElaboratedInstallPlan
-> PostBuildProjectStatus
-> [String]
argsEquivalentOfGhcEnvironmentFileGhc :: DistDirLayout
-> ElaboratedInstallPlan -> PostBuildProjectStatus -> [String]
argsEquivalentOfGhcEnvironmentFileGhc
DistDirLayout
distDirLayout
ElaboratedInstallPlan
elaboratedInstallPlan
PostBuildProjectStatus
postBuildStatus =
[String]
clearPackageDbStackFlag
forall a. [a] -> [a] -> [a]
++ PackageDBStack -> [String]
packageDbArgsDb PackageDBStack
packageDBs
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap 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 :: PackageDBStack
packageDBs = String -> PackageDBStack -> PackageDBStack
relativePackageDBPaths String
projectRootDir forall a b. (a -> b) -> a -> b
$
ElaboratedInstallPlan -> PackageDBStack
selectGhcEnvironmentFilePackageDbs ElaboratedInstallPlan
elaboratedInstallPlan
clearPackageDbStackFlag :: [String]
clearPackageDbStackFlag = [String
"-clear-package-db", String
"-global-package-db"]
packageIdFlag :: a -> [String]
packageIdFlag a
uid = [String
"-package-id", forall a. Pretty a => a -> String
prettyShow a
uid]
selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId]
selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId]
selectGhcEnvironmentFileLibraries PostBuildProjectStatus{Graph (Node UnitId ElaboratedPlanPackage)
PackagesUpToDate
packagesAlreadyInStore :: PackagesUpToDate
packagesBuildInplace :: PackagesUpToDate
packagesBuildLocal :: PackagesUpToDate
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
packagesInvalidByFailedBuild :: PackagesUpToDate
packagesInvalidByChangedLibDeps :: PackagesUpToDate
packagesOutOfDate :: PackagesUpToDate
packagesProbablyUpToDate :: PackagesUpToDate
packagesDefinitelyUpToDate :: PackagesUpToDate
packagesAlreadyInStore :: PostBuildProjectStatus -> PackagesUpToDate
packagesBuildInplace :: PostBuildProjectStatus -> PackagesUpToDate
packagesBuildLocal :: PostBuildProjectStatus -> PackagesUpToDate
packagesLibDepGraph :: PostBuildProjectStatus -> Graph (Node UnitId ElaboratedPlanPackage)
packagesInvalidByFailedBuild :: PostBuildProjectStatus -> PackagesUpToDate
packagesInvalidByChangedLibDeps :: PostBuildProjectStatus -> PackagesUpToDate
packagesOutOfDate :: PostBuildProjectStatus -> PackagesUpToDate
packagesProbablyUpToDate :: PostBuildProjectStatus -> PackagesUpToDate
packagesDefinitelyUpToDate :: PostBuildProjectStatus -> PackagesUpToDate
..} =
case forall a. Graph a -> [Key a] -> Maybe [a]
Graph.closure Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph (forall a. Set a -> [a]
Set.toList PackagesUpToDate
packagesBuildLocal) of
Maybe [Node UnitId ElaboratedPlanPackage]
Nothing -> 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
, 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
InstallPlan.PreExisting ipkg
_ -> Bool
True
InstallPlan.Installed ElaboratedConfiguredPackage
pkg -> ElaboratedConfiguredPackage -> Bool
elabRequiresRegistration ElaboratedConfiguredPackage
pkg
InstallPlan.Configured ElaboratedConfiguredPackage
pkg ->
ElaboratedConfiguredPackage -> Bool
elabRequiresRegistration ElaboratedConfiguredPackage
pkg
Bool -> Bool -> Bool
&& forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
pkg forall a. Ord a => a -> Set a -> Bool
`Set.member` PackagesUpToDate
packagesProbablyUpToDate
selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack
selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack
selectGhcEnvironmentFilePackageDbs ElaboratedInstallPlan
elaboratedInstallPlan =
case ([ElaboratedConfiguredPackage]
inplacePackages, [ElaboratedConfiguredPackage]
sourcePackages) of
([], [ElaboratedConfiguredPackage]
pkgs) -> [ElaboratedConfiguredPackage] -> PackageDBStack
checkSamePackageDBs [ElaboratedConfiguredPackage]
pkgs
([ElaboratedConfiguredPackage]
pkgs, [ElaboratedConfiguredPackage]
_) -> [ElaboratedConfiguredPackage] -> PackageDBStack
checkSamePackageDBs [ElaboratedConfiguredPackage]
pkgs
where
checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStack
checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStack
checkSamePackageDBs [ElaboratedConfiguredPackage]
pkgs =
case forall a. Ord a => [a] -> [a]
ordNub (forall a b. (a -> b) -> [a] -> [b]
map ElaboratedConfiguredPackage -> PackageDBStack
elabBuildPackageDBStack [ElaboratedConfiguredPackage]
pkgs) of
[PackageDBStack
packageDbs] -> PackageDBStack
packageDbs
[] -> []
[PackageDBStack]
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"renderGhcEnvironmentFile: packages with "
forall a. [a] -> [a] -> [a]
++ String
"different package db stacks"
inplacePackages :: [ElaboratedConfiguredPackage]
inplacePackages :: [ElaboratedConfiguredPackage]
inplacePackages =
[ ElaboratedConfiguredPackage
srcpkg
| ElaboratedConfiguredPackage
srcpkg <- [ElaboratedConfiguredPackage]
sourcePackages
, ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
srcpkg forall a. Eq a => a -> a -> Bool
== BuildStyle
BuildInplaceOnly ]
sourcePackages :: [ElaboratedConfiguredPackage]
sourcePackages :: [ElaboratedConfiguredPackage]
sourcePackages =
[ ElaboratedConfiguredPackage
srcpkg
| ElaboratedPlanPackage
pkg <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
elaboratedInstallPlan
, ElaboratedConfiguredPackage
srcpkg <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ case ElaboratedPlanPackage
pkg of
InstallPlan.Configured ElaboratedConfiguredPackage
srcpkg -> forall a. a -> Maybe a
Just ElaboratedConfiguredPackage
srcpkg
InstallPlan.Installed ElaboratedConfiguredPackage
srcpkg -> forall a. a -> Maybe a
Just ElaboratedConfiguredPackage
srcpkg
InstallPlan.PreExisting InstalledPackageInfo
_ -> forall a. Maybe a
Nothing
]
relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack
relativePackageDBPaths :: String -> PackageDBStack -> PackageDBStack
relativePackageDBPaths String
relroot = forall a b. (a -> b) -> [a] -> [b]
map (String -> PackageDB -> PackageDB
relativePackageDBPath String
relroot)
relativePackageDBPath :: FilePath -> PackageDB -> PackageDB
relativePackageDBPath :: String -> PackageDB -> PackageDB
relativePackageDBPath String
relroot PackageDB
pkgdb =
case PackageDB
pkgdb of
PackageDB
GlobalPackageDB -> PackageDB
GlobalPackageDB
PackageDB
UserPackageDB -> PackageDB
UserPackageDB
SpecificPackageDB String
path -> String -> PackageDB
SpecificPackageDB String
relpath
where relpath :: String
relpath = String -> String -> String
makeRelative String
relroot String
path