{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Stack.SourceMap
( mkProjectPackage
, snapToDepPackage
, additionalDepPackage
, loadVersion
, getPLIVersion
, loadGlobalHints
, DumpedGlobalPackage
, actualFromGhc
, actualFromHints
, checkFlagsUsedThrowing
, globalCondCheck
, pruneGlobals
, globalsFromHints
, getCompilerInfo
, immutableLocSha
, loadProjectSnapshotCandidate
, SnapshotCandidate
, globalsFromDump
) where
import Data.ByteString.Builder ( byteString )
import qualified Data.Conduit.List as CL
import qualified Distribution.PackageDescription as PD
import Distribution.System ( Platform (..) )
import qualified Pantry.SHA256 as SHA256
import qualified RIO.Map as Map
import RIO.Process
import qualified RIO.Set as Set
import Stack.PackageDump
import Stack.Prelude
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.SourceMap
mkProjectPackage ::
forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> PrintWarnings
-> ResolvedPath Dir
-> Bool
-> RIO env ProjectPackage
mkProjectPackage :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
printWarnings ResolvedPath Dir
dir Bool
buildHaddocks = do
(PrintWarnings -> IO GenericPackageDescription
gpd, PackageName
name, Path Abs File
cabalfp) <-
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') (forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectPackage
{ ppCabalFP :: Path Abs File
ppCabalFP = Path Abs File
cabalfp
, ppResolvedDir :: ResolvedPath Dir
ppResolvedDir = ResolvedPath Dir
dir
, ppCommon :: CommonPackage
ppCommon =
CommonPackage
{ cpGPD :: IO GenericPackageDescription
cpGPD = PrintWarnings -> IO GenericPackageDescription
gpd PrintWarnings
printWarnings
, cpName :: PackageName
cpName = PackageName
name
, cpFlags :: Map FlagName Bool
cpFlags = forall a. Monoid a => a
mempty
, cpGhcOptions :: [Text]
cpGhcOptions = forall a. Monoid a => a
mempty
, cpCabalConfigOpts :: [Text]
cpCabalConfigOpts = forall a. Monoid a => a
mempty
, cpHaddocks :: Bool
cpHaddocks = Bool
buildHaddocks
}
}
additionalDepPackage ::
forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Bool
-> PackageLocation
-> RIO env DepPackage
additionalDepPackage :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageLocation -> RIO env DepPackage
additionalDepPackage Bool
buildHaddocks PackageLocation
pl = do
(PackageName
name, IO GenericPackageDescription
gpdio) <-
case PackageLocation
pl of
PLMutable ResolvedPath Dir
dir -> do
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
name, Path Abs File
_cabalfp) <-
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') (forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
name, PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings)
PLImmutable PackageLocationImmutable
pli -> do
let PackageIdentifier PackageName
name Version
_ = PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
pli
RIO env GenericPackageDescription -> IO GenericPackageDescription
run <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
name, RIO env GenericPackageDescription -> IO GenericPackageDescription
run forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
pli)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DepPackage
{ dpLocation :: PackageLocation
dpLocation = PackageLocation
pl
, dpHidden :: Bool
dpHidden = Bool
False
, dpFromSnapshot :: FromSnapshot
dpFromSnapshot = FromSnapshot
NotFromSnapshot
, dpCommon :: CommonPackage
dpCommon =
CommonPackage
{ cpGPD :: IO GenericPackageDescription
cpGPD = IO GenericPackageDescription
gpdio
, cpName :: PackageName
cpName = PackageName
name
, cpFlags :: Map FlagName Bool
cpFlags = forall a. Monoid a => a
mempty
, cpGhcOptions :: [Text]
cpGhcOptions = forall a. Monoid a => a
mempty
, cpCabalConfigOpts :: [Text]
cpCabalConfigOpts = forall a. Monoid a => a
mempty
, cpHaddocks :: Bool
cpHaddocks = Bool
buildHaddocks
}
}
snapToDepPackage ::
forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Bool
-> PackageName
-> SnapshotPackage
-> RIO env DepPackage
snapToDepPackage :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageName -> SnapshotPackage -> RIO env DepPackage
snapToDepPackage Bool
buildHaddocks PackageName
name SnapshotPackage{Bool
[Text]
Map FlagName Bool
PackageLocationImmutable
spLocation :: SnapshotPackage -> PackageLocationImmutable
spFlags :: SnapshotPackage -> Map FlagName Bool
spHidden :: SnapshotPackage -> Bool
spGhcOptions :: SnapshotPackage -> [Text]
spGhcOptions :: [Text]
spHidden :: Bool
spFlags :: Map FlagName Bool
spLocation :: PackageLocationImmutable
..} = do
RIO env GenericPackageDescription -> IO GenericPackageDescription
run <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
forall (f :: * -> *) a. Applicative f => a -> f a
pure DepPackage
{ dpLocation :: PackageLocation
dpLocation = PackageLocationImmutable -> PackageLocation
PLImmutable PackageLocationImmutable
spLocation
, dpHidden :: Bool
dpHidden = Bool
spHidden
, dpFromSnapshot :: FromSnapshot
dpFromSnapshot = FromSnapshot
FromSnapshot
, dpCommon :: CommonPackage
dpCommon =
CommonPackage
{ cpGPD :: IO GenericPackageDescription
cpGPD = RIO env GenericPackageDescription -> IO GenericPackageDescription
run forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
spLocation
, cpName :: PackageName
cpName = PackageName
name
, cpFlags :: Map FlagName Bool
cpFlags = Map FlagName Bool
spFlags
, cpGhcOptions :: [Text]
cpGhcOptions = [Text]
spGhcOptions
, cpCabalConfigOpts :: [Text]
cpCabalConfigOpts = []
, cpHaddocks :: Bool
cpHaddocks = Bool
buildHaddocks
}
}
loadVersion :: MonadIO m => CommonPackage -> m Version
loadVersion :: forall (m :: * -> *). MonadIO m => CommonPackage -> m Version
loadVersion CommonPackage
common = do
GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CommonPackage -> IO GenericPackageDescription
cpGPD CommonPackage
common
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier -> Version
pkgVersion forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
PD.packageDescription GenericPackageDescription
gpd)
getPLIVersion :: PackageLocationImmutable -> Version
getPLIVersion :: PackageLocationImmutable -> Version
getPLIVersion (PLIHackage (PackageIdentifier PackageName
_ Version
v) BlobKey
_ TreeKey
_) = Version
v
getPLIVersion (PLIArchive Archive
_ PackageMetadata
pm) = PackageIdentifier -> Version
pkgVersion forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm
getPLIVersion (PLIRepo Repo
_ PackageMetadata
pm) = PackageIdentifier -> Version
pkgVersion forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm
globalsFromDump ::
(HasLogFunc env, HasProcessContext env)
=> GhcPkgExe
-> RIO env (Map PackageName DumpedGlobalPackage)
globalsFromDump :: forall env.
(HasLogFunc env, HasProcessContext env) =>
GhcPkgExe -> RIO env (Map PackageName DumpedGlobalPackage)
globalsFromDump GhcPkgExe
pkgexe = do
let pkgConduit :: ConduitT Text c (RIO env) (Map GhcPkgId DumpedGlobalPackage)
pkgConduit = forall (m :: * -> *).
MonadThrow m =>
ConduitM Text DumpedGlobalPackage m ()
conduitDumpPackage
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) b a o.
(Monad m, Monoid b) =>
(a -> b) -> ConduitT a o m b
CL.foldMap (\DumpedGlobalPackage
dp -> forall k a. k -> a -> Map k a
Map.singleton (DumpedGlobalPackage -> GhcPkgId
dpGhcPkgId DumpedGlobalPackage
dp) DumpedGlobalPackage
dp)
toGlobals :: Map k DumpedGlobalPackage -> Map PackageName DumpedGlobalPackage
toGlobals Map k DumpedGlobalPackage
ds =
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> PackageName
pkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpedGlobalPackage -> PackageIdentifier
dpPackageIdent forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map k DumpedGlobalPackage
ds
forall {k}.
Map k DumpedGlobalPackage -> Map PackageName DumpedGlobalPackage
toGlobals forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env a.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [Path Abs Dir] -> ConduitM Text Void (RIO env) a -> RIO env a
ghcPkgDump GhcPkgExe
pkgexe [] forall {c}.
ConduitT Text c (RIO env) (Map GhcPkgId DumpedGlobalPackage)
pkgConduit
globalsFromHints ::
HasConfig env
=> WantedCompiler
-> RIO env (Map PackageName Version)
globalsFromHints :: forall env.
HasConfig env =>
WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints WantedCompiler
compiler = do
Maybe (Map PackageName Version)
mglobalHints <- forall env.
(HasTerm env, HasPantryConfig env) =>
WantedCompiler -> RIO env (Maybe (Map PackageName Version))
loadGlobalHints WantedCompiler
compiler
case Maybe (Map PackageName Version)
mglobalHints of
Just Map PackageName Version
hints -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PackageName Version
hints
Maybe (Map PackageName Version)
Nothing -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Unable to load global hints for " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display WantedCompiler
compiler
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
type DumpedGlobalPackage = DumpPackage
actualFromGhc ::
(HasConfig env, HasCompiler env)
=> SMWanted
-> ActualCompiler
-> RIO env (SMActual DumpedGlobalPackage)
actualFromGhc :: forall env.
(HasConfig env, HasCompiler env) =>
SMWanted
-> ActualCompiler -> RIO env (SMActual DumpedGlobalPackage)
actualFromGhc SMWanted
smw ActualCompiler
ac = do
Map PackageName DumpedGlobalPackage
globals <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Map PackageName DumpedGlobalPackage
cpGlobalDump
forall (f :: * -> *) a. Applicative f => a -> f a
pure
SMActual
{ smaCompiler :: ActualCompiler
smaCompiler = ActualCompiler
ac
, smaProject :: Map PackageName ProjectPackage
smaProject = SMWanted -> Map PackageName ProjectPackage
smwProject SMWanted
smw
, smaDeps :: Map PackageName DepPackage
smaDeps = SMWanted -> Map PackageName DepPackage
smwDeps SMWanted
smw
, smaGlobal :: Map PackageName DumpedGlobalPackage
smaGlobal = Map PackageName DumpedGlobalPackage
globals
}
actualFromHints ::
(HasConfig env)
=> SMWanted
-> ActualCompiler
-> RIO env (SMActual GlobalPackageVersion)
actualFromHints :: forall env.
HasConfig env =>
SMWanted
-> ActualCompiler -> RIO env (SMActual GlobalPackageVersion)
actualFromHints SMWanted
smw ActualCompiler
ac = do
Map PackageName Version
globals <- forall env.
HasConfig env =>
WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints (ActualCompiler -> WantedCompiler
actualToWanted ActualCompiler
ac)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
SMActual
{ smaCompiler :: ActualCompiler
smaCompiler = ActualCompiler
ac
, smaProject :: Map PackageName ProjectPackage
smaProject = SMWanted -> Map PackageName ProjectPackage
smwProject SMWanted
smw
, smaDeps :: Map PackageName DepPackage
smaDeps = SMWanted -> Map PackageName DepPackage
smwDeps SMWanted
smw
, smaGlobal :: Map PackageName GlobalPackageVersion
smaGlobal = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Version -> GlobalPackageVersion
GlobalPackageVersion Map PackageName Version
globals
}
globalCondCheck ::
(HasConfig env)
=> RIO env (PD.ConfVar
-> Either PD.ConfVar Bool)
globalCondCheck :: forall env.
HasConfig env =>
RIO env (ConfVar -> Either ConfVar Bool)
globalCondCheck = do
Platform Arch
arch OS
os <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
let condCheck :: ConfVar -> Either ConfVar Bool
condCheck (PD.OS OS
os') = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ OS
os' forall a. Eq a => a -> a -> Bool
== OS
os
condCheck (PD.Arch Arch
arch') = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Arch
arch' forall a. Eq a => a -> a -> Bool
== Arch
arch
condCheck ConfVar
c = forall a b. a -> Either a b
Left ConfVar
c
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfVar -> Either ConfVar Bool
condCheck
checkFlagsUsedThrowing ::
(MonadIO m, MonadThrow m)
=> Map PackageName (Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m ()
checkFlagsUsedThrowing :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Map PackageName (Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m ()
checkFlagsUsedThrowing Map PackageName (Map FlagName Bool)
packageFlags FlagSource
source Map PackageName ProjectPackage
prjPackages Map PackageName DepPackage
deps = do
[UnusedFlags]
unusedFlags <-
forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Map FlagName Bool)
packageFlags) forall a b. (a -> b) -> a -> b
$ \(PackageName
pname, Map FlagName Bool
flags) ->
forall (m :: * -> *).
MonadIO m =>
(PackageName, Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m (Maybe UnusedFlags)
getUnusedPackageFlags (PackageName
pname, Map FlagName Bool
flags) FlagSource
source Map PackageName ProjectPackage
prjPackages Map PackageName DepPackage
deps
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnusedFlags]
unusedFlags) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Set UnusedFlags -> BuildException
InvalidFlagSpecification forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [UnusedFlags]
unusedFlags
getUnusedPackageFlags ::
MonadIO m
=> (PackageName, Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m (Maybe UnusedFlags)
getUnusedPackageFlags :: forall (m :: * -> *).
MonadIO m =>
(PackageName, Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m (Maybe UnusedFlags)
getUnusedPackageFlags (PackageName
name, Map FlagName Bool
userFlags) FlagSource
source Map PackageName ProjectPackage
prj Map PackageName DepPackage
deps =
let maybeCommon :: Maybe CommonPackage
maybeCommon = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProjectPackage -> CommonPackage
ppCommon (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName ProjectPackage
prj)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DepPackage -> CommonPackage
dpCommon (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName DepPackage
deps)
in case Maybe CommonPackage
maybeCommon of
Maybe CommonPackage
Nothing ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FlagSource -> PackageName -> UnusedFlags
UFNoPackage FlagSource
source PackageName
name
Just CommonPackage
common -> do
GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CommonPackage -> IO GenericPackageDescription
cpGPD CommonPackage
common
let pname :: PackageName
pname = PackageIdentifier -> PackageName
pkgName forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
PD.packageDescription GenericPackageDescription
gpd
pkgFlags :: Set FlagName
pkgFlags = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> FlagName
PD.flagName forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> [PackageFlag]
PD.genPackageFlags GenericPackageDescription
gpd
unused :: Set FlagName
unused = forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map FlagName Bool
userFlags Set FlagName
pkgFlags
if forall a. Set a -> Bool
Set.null Set FlagName
unused
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FlagSource
-> PackageName -> Set FlagName -> Set FlagName -> UnusedFlags
UFFlagsNotDefined FlagSource
source PackageName
pname Set FlagName
pkgFlags Set FlagName
unused
pruneGlobals ::
Map PackageName DumpedGlobalPackage
-> Set PackageName
-> Map PackageName GlobalPackage
pruneGlobals :: Map PackageName DumpedGlobalPackage
-> Set PackageName -> Map PackageName GlobalPackage
pruneGlobals Map PackageName DumpedGlobalPackage
globals Set PackageName
deps =
let (Map PackageName [PackageName]
prunedGlobals, Map PackageName DumpedGlobalPackage
keptGlobals) =
forall id a.
Ord id =>
Map PackageName a
-> (a -> PackageName)
-> (a -> id)
-> (a -> [id])
-> Set PackageName
-> (Map PackageName [PackageName], Map PackageName a)
partitionReplacedDependencies Map PackageName DumpedGlobalPackage
globals (PackageIdentifier -> PackageName
pkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpedGlobalPackage -> PackageIdentifier
dpPackageIdent)
DumpedGlobalPackage -> GhcPkgId
dpGhcPkgId DumpedGlobalPackage -> [GhcPkgId]
dpDepends Set PackageName
deps
in forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Version -> GlobalPackage
GlobalPackage forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
pkgVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpedGlobalPackage -> PackageIdentifier
dpPackageIdent) Map PackageName DumpedGlobalPackage
keptGlobals forall a. Semigroup a => a -> a -> a
<>
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [PackageName] -> GlobalPackage
ReplacedGlobalPackage Map PackageName [PackageName]
prunedGlobals
getCompilerInfo :: (HasConfig env, HasCompiler env) => RIO env Builder
getCompilerInfo :: forall env. (HasConfig env, HasCompiler env) => RIO env Builder
getCompilerInfo = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (ByteString -> Builder
byteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerPaths -> ByteString
cpGhcInfo)
immutableLocSha :: PackageLocationImmutable -> Builder
immutableLocSha :: PackageLocationImmutable -> Builder
immutableLocSha = ByteString -> Builder
byteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeKey -> ByteString
treeKeyToBs forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocationImmutable -> TreeKey
locationTreeKey
where
locationTreeKey :: PackageLocationImmutable -> TreeKey
locationTreeKey (PLIHackage PackageIdentifier
_ BlobKey
_ TreeKey
tk) = TreeKey
tk
locationTreeKey (PLIArchive Archive
_ PackageMetadata
pm) = PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm
locationTreeKey (PLIRepo Repo
_ PackageMetadata
pm) = PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm
treeKeyToBs :: TreeKey -> ByteString
treeKeyToBs (TreeKey (BlobKey SHA256
sha FileSize
_)) = SHA256 -> ByteString
SHA256.toHexBytes SHA256
sha
type SnapshotCandidate env
= [ResolvedPath Dir] -> RIO env (SMActual GlobalPackageVersion)
loadProjectSnapshotCandidate ::
(HasConfig env)
=> RawSnapshotLocation
-> PrintWarnings
-> Bool
-> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate :: forall env.
HasConfig env =>
RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate RawSnapshotLocation
loc PrintWarnings
printWarnings Bool
buildHaddocks = do
Bool
debugRSL <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => SimpleGetter env Bool
rslInLogL
(Snapshot
snapshot, [CompletedSL]
_, [CompletedPLI]
_) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
debugRSL RawSnapshotLocation
loc forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty
Map PackageName DepPackage
deps <- forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageName -> SnapshotPackage -> RIO env DepPackage
snapToDepPackage Bool
False) (Snapshot -> Map PackageName SnapshotPackage
snapshotPackages Snapshot
snapshot)
let wc :: WantedCompiler
wc = Snapshot -> WantedCompiler
snapshotCompiler Snapshot
snapshot
Map PackageName GlobalPackageVersion
globals <- forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Version -> GlobalPackageVersion
GlobalPackageVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
HasConfig env =>
WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints WantedCompiler
wc
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \[ResolvedPath Dir]
projectPackages -> do
Map PackageName ProjectPackage
prjPkgs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ResolvedPath Dir]
projectPackages forall a b. (a -> b) -> a -> b
$ \ResolvedPath Dir
resolved -> do
ProjectPackage
pp <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
printWarnings ResolvedPath Dir
resolved Bool
buildHaddocks
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommonPackage -> PackageName
cpName forall a b. (a -> b) -> a -> b
$ ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp, ProjectPackage
pp)
ActualCompiler
compiler <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual forall a b. (a -> b) -> a -> b
$ Snapshot -> WantedCompiler
snapshotCompiler Snapshot
snapshot
forall (f :: * -> *) a. Applicative f => a -> f a
pure
SMActual
{ smaCompiler :: ActualCompiler
smaCompiler = ActualCompiler
compiler
, smaProject :: Map PackageName ProjectPackage
smaProject = Map PackageName ProjectPackage
prjPkgs
, smaDeps :: Map PackageName DepPackage
smaDeps = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map PackageName DepPackage
deps Map PackageName ProjectPackage
prjPkgs
, smaGlobal :: Map PackageName GlobalPackageVersion
smaGlobal = Map PackageName GlobalPackageVersion
globals
}