{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}

{-|
Module      : Stack.SourceMap
License     : BSD-3-Clause
-}

module Stack.SourceMap
  ( mkProjectPackage
  , snapToDepPackage
  , additionalDepPackage
  , loadVersion
  , getPLIVersion
  , loadGlobalHints
  , actualFromGhc
  , globalCondCheck
  , pruneGlobals
  , globalsFromHints
  , getCompilerInfo
  , immutableLocSha
  , loadProjectSnapshotCandidate
  , SnapshotCandidate
  , globalsFromDump
  ) where

import           Data.ByteString.Builder ( byteString )
import qualified Data.Conduit.List as CL
import qualified Data.Text as T
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 ( HasProcessContext )
import           Stack.Constants ( stackProgName' )
import           Stack.PackageDump ( conduitDumpPackage, ghcPkgDump )
import           Stack.Prelude
import           Stack.Types.Compiler
                   ( ActualCompiler, wantedToActual )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), GhcPkgExe, HasCompiler (..) )
import           Stack.Types.Config ( HasConfig )
import           Stack.Types.DumpPackage
                   ( DumpPackage (..), DumpedGlobalPackage )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( rslInLogL )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), FromSnapshot (..)
                   , GlobalPackage (..), GlobalPackageVersion (..)
                   , ProjectPackage (..), SMActual (..), SMWanted (..)
                   )

-- | Create a t'ProjectPackage' from a directory containing a package.

mkProjectPackage ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PrintWarnings
  -> ResolvedPath Dir
  -> Bool
     -- ^ Should Haddock documentation be built for the package?

  -> RIO env ProjectPackage
mkProjectPackage :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
printWarnings ResolvedPath Dir
resolvedDir Bool
buildHaddocks = do
  (gpd, name, cabalFP) <-
    Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
resolvedDir)
  pure ProjectPackage
    { cabalFP
    , resolvedDir
    , projectCommon =
        CommonPackage
          { gpd = gpd printWarnings
          , name
          , flags = mempty
          , ghcOptions = mempty
          , cabalConfigOpts = mempty
          , buildHaddocks
          }
    }

-- | Create a t'DepPackage' from a 'PackageLocation', from some additional to a

-- snapshot setting (extra-deps or command line).

additionalDepPackage ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Bool
     -- ^ Should Haddock documentation be built for the package?

  -> PackageLocation
  -> RIO env DepPackage
additionalDepPackage :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageLocation -> RIO env DepPackage
additionalDepPackage Bool
buildHaddocks PackageLocation
location = do
  (name, gpd) <-
    case PackageLocation
location of
      PLMutable ResolvedPath Dir
dir -> do
        (gpd, name, _cabalfp) <-
          Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
dir)
        pure (name, gpd NoPrintWarnings)
      PLImmutable PackageLocationImmutable
pli -> do
        let PackageIdentifier PackageName
name Version
_ = PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
pli
        run <- RIO
  env
  (RIO env GenericPackageDescription -> IO GenericPackageDescription)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
        pure (name, run $ loadCabalFileImmutable pli)
  pure DepPackage
    { location
    , hidden = False
    , fromSnapshot = NotFromSnapshot
    , depCommon =
        CommonPackage
          { gpd
          , name
          , flags = mempty
          , ghcOptions = mempty
          , cabalConfigOpts = mempty
          , buildHaddocks
          }
    }

-- | Given a t'PackageName' and its t'SnapshotPackage', yields the corresponding

-- t'DepPackage'.

snapToDepPackage ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Bool
     -- ^ Should Haddock documentation be built for the package?

  -> 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
sp = do
  run <- RIO
  env
  (RIO env GenericPackageDescription -> IO GenericPackageDescription)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
  pure DepPackage
    { location = PLImmutable sp.spLocation
    , hidden = sp.spHidden
    , fromSnapshot = FromSnapshot
    , depCommon =
        CommonPackage
          { gpd = run $ loadCabalFileImmutable sp.spLocation
          , name
          , flags = sp.spFlags
          , ghcOptions = sp.spGhcOptions
          , cabalConfigOpts = [] -- No spCabalConfigOpts, not present in snapshots

          , buildHaddocks
          }
    }

-- | For the given t'CommonPackage', load its generic package description and

-- yield its version.

loadVersion :: MonadIO m => CommonPackage -> m Version
loadVersion :: forall (m :: * -> *). MonadIO m => CommonPackage -> m Version
loadVersion CommonPackage
common = do
  gpd <- IO GenericPackageDescription -> m GenericPackageDescription
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO CommonPackage
common.gpd
  pure gpd.packageDescription.package.pkgVersion

-- | For the given t'PackageLocationImmutable', yield the version of the

-- referenced package.

getPLIVersion :: PackageLocationImmutable -> Version
getPLIVersion :: PackageLocationImmutable -> Version
getPLIVersion (PLIHackage (PackageIdentifier PackageName
_ Version
v) BlobKey
_ TreeKey
_) = Version
v
getPLIVersion (PLIArchive Archive
_ PackageMetadata
pm) = PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm
getPLIVersion (PLIRepo Repo
_ PackageMetadata
pm) = PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm

-- | For the given @ghc-pkg@ executable, yield the contents of the global

-- package database.

globalsFromDump ::
     (HasProcessContext env, HasTerm env)
  => GhcPkgExe
  -> RIO env (Map PackageName DumpedGlobalPackage)
globalsFromDump :: forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe -> RIO env (Map PackageName DumpedGlobalPackage)
globalsFromDump GhcPkgExe
pkgexe = do
  let pkgConduit :: ConduitT Text c (RIO env) (Map GhcPkgId DumpedGlobalPackage)
pkgConduit =    ConduitM Text DumpedGlobalPackage (RIO env) ()
forall (m :: * -> *).
MonadThrow m =>
ConduitM Text DumpedGlobalPackage m ()
conduitDumpPackage
                   ConduitM Text DumpedGlobalPackage (RIO env) ()
-> ConduitT
     DumpedGlobalPackage c (RIO env) (Map GhcPkgId DumpedGlobalPackage)
-> ConduitT Text c (RIO env) (Map GhcPkgId DumpedGlobalPackage)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (DumpedGlobalPackage -> Map GhcPkgId DumpedGlobalPackage)
-> ConduitT
     DumpedGlobalPackage c (RIO env) (Map GhcPkgId DumpedGlobalPackage)
forall (m :: * -> *) b a o.
(Monad m, Monoid b) =>
(a -> b) -> ConduitT a o m b
CL.foldMap (\DumpedGlobalPackage
dp -> GhcPkgId -> DumpedGlobalPackage -> Map GhcPkgId DumpedGlobalPackage
forall k a. k -> a -> Map k a
Map.singleton DumpedGlobalPackage
dp.ghcPkgId DumpedGlobalPackage
dp)
      toGlobals :: Map k a -> Map PackageName a
toGlobals Map k a
ds =
        [(PackageName, a)] -> Map PackageName a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, a)] -> Map PackageName a)
-> [(PackageName, a)] -> Map PackageName a
forall a b. (a -> b) -> a -> b
$ (a -> (PackageName, a)) -> [a] -> [(PackageName, a)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (a -> PackageIdentifier) -> a -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.packageIdent) (a -> PackageName) -> (a -> a) -> a -> (PackageName, a)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> a
forall a. a -> a
id) ([a] -> [(PackageName, a)]) -> [a] -> [(PackageName, a)]
forall a b. (a -> b) -> a -> b
$ Map k a -> [a]
forall k a. Map k a -> [a]
Map.elems Map k a
ds
  Map GhcPkgId DumpedGlobalPackage
-> Map PackageName DumpedGlobalPackage
forall {a} {k}.
HasField "packageIdent" a PackageIdentifier =>
Map k a -> Map PackageName a
toGlobals (Map GhcPkgId DumpedGlobalPackage
 -> Map PackageName DumpedGlobalPackage)
-> RIO env (Map GhcPkgId DumpedGlobalPackage)
-> RIO env (Map PackageName DumpedGlobalPackage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GhcPkgExe
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) (Map GhcPkgId DumpedGlobalPackage)
-> RIO env (Map GhcPkgId DumpedGlobalPackage)
forall env a.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir] -> ConduitM Text Void (RIO env) a -> RIO env a
ghcPkgDump GhcPkgExe
pkgexe [] ConduitM Text Void (RIO env) (Map GhcPkgId DumpedGlobalPackage)
forall {c}.
ConduitT Text c (RIO env) (Map GhcPkgId DumpedGlobalPackage)
pkgConduit

-- | For the given wanted compiler, yield the global hints (if available).

globalsFromHints ::
     HasConfig env
  => WantedCompiler
  -> RIO env (Map PackageName Version)
globalsFromHints :: forall env.
HasConfig env =>
WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints WantedCompiler
compiler = WantedCompiler -> RIO env (Maybe (Map PackageName Version))
forall env.
(HasTerm env, HasPantryConfig env) =>
WantedCompiler -> RIO env (Maybe (Map PackageName Version))
loadGlobalHints WantedCompiler
compiler RIO env (Maybe (Map PackageName Version))
-> (Maybe (Map PackageName Version)
    -> RIO env (Map PackageName Version))
-> RIO env (Map PackageName Version)
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RIO env (Map PackageName Version)
-> (Map PackageName Version -> RIO env (Map PackageName Version))
-> Maybe (Map PackageName Version)
-> RIO env (Map PackageName Version)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
  ( do
      [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
        [ String -> StyleDoc
flow String
"Unable to load global hints for"
        , String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Text
forall a. Display a => a -> Text
textDisplay WantedCompiler
compiler
        ]
      Map PackageName Version -> RIO env (Map PackageName Version)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PackageName Version
forall a. Monoid a => a
mempty
  )
  Map PackageName Version -> RIO env (Map PackageName Version)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | When the environment 'HasCompiler', for the

-- given t'Stack.Types.SourceMap.SMWanted' and 'ActualCompiler', yield

-- a t'SMActual' parameterised by t'DumpedGlobalPackage'.

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
compiler = do
  globals <- Getting
  (Map PackageName DumpedGlobalPackage)
  env
  (Map PackageName DumpedGlobalPackage)
-> RIO env (Map PackageName DumpedGlobalPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName DumpedGlobalPackage)
   env
   (Map PackageName DumpedGlobalPackage)
 -> RIO env (Map PackageName DumpedGlobalPackage))
-> Getting
     (Map PackageName DumpedGlobalPackage)
     env
     (Map PackageName DumpedGlobalPackage)
-> RIO env (Map PackageName DumpedGlobalPackage)
forall a b. (a -> b) -> a -> b
$ Getting (Map PackageName DumpedGlobalPackage) env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter env CompilerPaths
compilerPathsL Getting (Map PackageName DumpedGlobalPackage) env CompilerPaths
-> ((Map PackageName DumpedGlobalPackage
     -> Const
          (Map PackageName DumpedGlobalPackage)
          (Map PackageName DumpedGlobalPackage))
    -> CompilerPaths
    -> Const (Map PackageName DumpedGlobalPackage) CompilerPaths)
-> Getting
     (Map PackageName DumpedGlobalPackage)
     env
     (Map PackageName DumpedGlobalPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerPaths -> Map PackageName DumpedGlobalPackage)
-> SimpleGetter CompilerPaths (Map PackageName DumpedGlobalPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (.globalDump)
  pure
    SMActual
      { compiler
      , project = smw.project
      , deps = smw.deps
      , globals
      }

-- | Simple cond check for boot packages - checks only OS and Arch

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 os <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
  let condCheck (PD.OS OS
os') = Bool -> Either ConfVar Bool
forall a. a -> Either ConfVar a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Either ConfVar Bool) -> Bool -> Either ConfVar Bool
forall a b. (a -> b) -> a -> b
$ OS
os' OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
os
      condCheck (PD.Arch Arch
arch') = Bool -> Either ConfVar Bool
forall a. a -> Either ConfVar a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Either ConfVar Bool) -> Bool -> Either ConfVar Bool
forall a b. (a -> b) -> a -> b
$ Arch
arch' Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
arch
      condCheck ConfVar
c = ConfVar -> Either ConfVar Bool
forall a b. a -> Either a b
Left ConfVar
c
  pure condCheck

-- | Prune the given packages from GHC's global package database.

pruneGlobals ::
     Map PackageName DumpedGlobalPackage
     -- ^ Packages in GHC's global package database.

  -> Set PackageName
     -- ^ Package names to prune.

  -> 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) =
        Map PackageName DumpedGlobalPackage
-> (DumpedGlobalPackage -> PackageName)
-> (DumpedGlobalPackage -> GhcPkgId)
-> (DumpedGlobalPackage -> [GhcPkgId])
-> Set PackageName
-> (Map PackageName [PackageName],
    Map PackageName DumpedGlobalPackage)
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 (PackageIdentifier -> PackageName)
-> (DumpedGlobalPackage -> PackageIdentifier)
-> DumpedGlobalPackage
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.packageIdent))
          (.ghcPkgId) (.depends) Set PackageName
deps
  in  (DumpedGlobalPackage -> GlobalPackage)
-> Map PackageName DumpedGlobalPackage
-> Map PackageName GlobalPackage
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Version -> GlobalPackage
GlobalPackage (Version -> GlobalPackage)
-> (DumpedGlobalPackage -> Version)
-> DumpedGlobalPackage
-> GlobalPackage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version)
-> (DumpedGlobalPackage -> PackageIdentifier)
-> DumpedGlobalPackage
-> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.packageIdent)) Map PackageName DumpedGlobalPackage
keptGlobals Map PackageName GlobalPackage
-> Map PackageName GlobalPackage -> Map PackageName GlobalPackage
forall a. Semigroup a => a -> a -> a
<>
      ([PackageName] -> GlobalPackage)
-> Map PackageName [PackageName] -> Map PackageName GlobalPackage
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [PackageName] -> GlobalPackage
ReplacedGlobalPackage Map PackageName [PackageName]
prunedGlobals

-- | Get the output of @ghc --info@ for the compiler in the environment.

getCompilerInfo :: (HasConfig env, HasCompiler env) => RIO env Builder
getCompilerInfo :: forall env. (HasConfig env, HasCompiler env) => RIO env Builder
getCompilerInfo = Getting Builder env Builder -> RIO env Builder
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Builder env Builder -> RIO env Builder)
-> Getting Builder env Builder -> RIO env Builder
forall a b. (a -> b) -> a -> b
$ Getting Builder env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter env CompilerPaths
compilerPathsL Getting Builder env CompilerPaths
-> ((Builder -> Const Builder Builder)
    -> CompilerPaths -> Const Builder CompilerPaths)
-> Getting Builder env Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerPaths -> Builder) -> SimpleGetter CompilerPaths Builder
forall s a. (s -> a) -> SimpleGetter s a
to (StrictByteString -> Builder
byteString (StrictByteString -> Builder)
-> (CompilerPaths -> StrictByteString) -> CompilerPaths -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.ghcInfo))

-- | For the given 'PackageLocationImmutable', yield its 256-bit cryptographic

-- hash.

immutableLocSha :: PackageLocationImmutable -> Builder
immutableLocSha :: PackageLocationImmutable -> Builder
immutableLocSha = StrictByteString -> Builder
byteString (StrictByteString -> Builder)
-> (PackageLocationImmutable -> StrictByteString)
-> PackageLocationImmutable
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeKey -> StrictByteString
treeKeyToBs (TreeKey -> StrictByteString)
-> (PackageLocationImmutable -> TreeKey)
-> PackageLocationImmutable
-> StrictByteString
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 -> StrictByteString
treeKeyToBs (TreeKey (BlobKey SHA256
sha FileSize
_)) = SHA256 -> StrictByteString
SHA256.toHexBytes SHA256
sha

-- | Type synonym for functions that yield a t'SMActual' parameterised by

-- t'GlobalPackageVersion' for a given list of project package directories.

type SnapshotCandidate env
  = [ResolvedPath Dir] -> RIO env (SMActual GlobalPackageVersion)

-- | For the given raw snapshot location, yield a function to yield a

-- t'SMActual' from a list of project package directories.

loadProjectSnapshotCandidate ::
     (HasConfig env)
  => RawSnapshotLocation
  -> PrintWarnings
  -> Bool
     -- ^ Should Haddock documentation be build for the package?

  -> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate :: forall env.
HasConfig env =>
RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate RawSnapshotLocation
loc PrintWarnings
printWarnings Bool
buildHaddocks = do
  debugRSL <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool env Bool
forall env. HasRunner env => SimpleGetter env Bool
SimpleGetter env Bool
rslInLogL
  (snapshot, _, _) <-
    loadAndCompleteSnapshotRaw' debugRSL loc Map.empty Map.empty
  deps <-
    Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot)
  let wc = Snapshot -> WantedCompiler
snapshotCompiler Snapshot
snapshot
  globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc
  pure $ \[ResolvedPath Dir]
projectPackages -> do
    project <- ([(PackageName, ProjectPackage)] -> Map PackageName ProjectPackage)
-> RIO env [(PackageName, ProjectPackage)]
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(PackageName, ProjectPackage)] -> Map PackageName ProjectPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (RIO env [(PackageName, ProjectPackage)]
 -> RIO env (Map PackageName ProjectPackage))
-> ((ResolvedPath Dir -> RIO env (PackageName, ProjectPackage))
    -> RIO env [(PackageName, ProjectPackage)])
-> (ResolvedPath Dir -> RIO env (PackageName, ProjectPackage))
-> RIO env (Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ResolvedPath Dir]
-> (ResolvedPath Dir -> RIO env (PackageName, ProjectPackage))
-> RIO env [(PackageName, ProjectPackage)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ResolvedPath Dir]
projectPackages ((ResolvedPath Dir -> RIO env (PackageName, ProjectPackage))
 -> RIO env (Map PackageName ProjectPackage))
-> (ResolvedPath Dir -> RIO env (PackageName, ProjectPackage))
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ \ResolvedPath Dir
resolved -> do
      pp <- PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
printWarnings ResolvedPath Dir
resolved Bool
buildHaddocks
      pure (pp.projectCommon.name, pp)
    compiler <- either throwIO pure $ wantedToActual $ snapshotCompiler snapshot
    pure
      SMActual
        { compiler
        , project
        , deps = Map.difference deps project
        , globals
        }