{-# 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
import qualified RIO.Map as Map
import qualified RIO.Set as Set
import RIO.Process
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) =>
Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
dir)
forall (m :: * -> *) a. Monad m => a -> m a
return 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) =>
Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return (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
RIO.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 (m :: * -> *) a. Monad m => a -> m a
return
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 (m :: * -> *) a. Monad m => a -> m a
return
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 (m :: * -> *) a. Monad m => a -> m a
return 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 -> StackBuildException
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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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
}