{-# LANGUAGE OverloadedStrings #-}
{-# 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 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 qualified RIO.Set as Set
import           Stack.Constants ( stackProgName' )
import           Stack.PackageDump ( conduitDumpPackage, ghcPkgDump )
import           Stack.Prelude
import           Stack.Types.Build.Exception ( BuildPrettyException (..) )
import           Stack.Types.Compiler
                   ( ActualCompiler, actualToWanted, wantedToActual )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), GhcPkgExe, HasCompiler (..) )
import           Stack.Types.Config ( HasConfig )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.UnusedFlags ( FlagSource, UnusedFlags (..) )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( rslInLogL )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), FromSnapshot (..)
                   , GlobalPackage (..), GlobalPackageVersion (..)
                   , ProjectPackage (..), SMActual (..), SMWanted (..)
                   )

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

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
          }
    }

-- | Create a '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
  -> 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 = [] -- No spCabalConfigOpts, not present in snapshots

          , 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 ::
     (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 =    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, HasTerm 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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
        [ String -> StyleDoc
flow String
"Unable to load global hints for"
        , forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay 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
      }

-- | 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
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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ Set UnusedFlags -> BuildPrettyException
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
        -- Package is not available as project or dependency

        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
        -- Package exists, let's check if the flags are defined

        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
            -- All flags are defined, nothing to do

            then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            -- Error about the undefined flags

            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
        }