{-# 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 Pantry
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

-- | 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 :: 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) <- Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
dir)
   ProjectPackage -> RIO env ProjectPackage
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectPackage :: CommonPackage
-> Path Abs File -> ResolvedPath Dir -> ProjectPackage
ProjectPackage
     { ppCabalFP :: Path Abs File
ppCabalFP = Path Abs File
cabalfp
     , ppResolvedDir :: ResolvedPath Dir
ppResolvedDir = ResolvedPath Dir
dir
     , ppCommon :: CommonPackage
ppCommon = CommonPackage :: IO GenericPackageDescription
-> PackageName
-> Map FlagName Bool
-> [Text]
-> [Text]
-> Bool
-> CommonPackage
CommonPackage
                  { cpGPD :: IO GenericPackageDescription
cpGPD = PrintWarnings -> IO GenericPackageDescription
gpd PrintWarnings
printWarnings
                  , cpName :: PackageName
cpName = PackageName
name
                  , cpFlags :: Map FlagName Bool
cpFlags = Map FlagName Bool
forall a. Monoid a => a
mempty
                  , cpGhcOptions :: [Text]
cpGhcOptions = [Text]
forall a. Monoid a => a
mempty
                  , cpCabalConfigOpts :: [Text]
cpCabalConfigOpts = [Text]
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 :: 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) <- Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
dir)
        (PackageName, IO GenericPackageDescription)
-> RIO env (PackageName, IO GenericPackageDescription)
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 <- RIO
  env
  (RIO env GenericPackageDescription -> IO GenericPackageDescription)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
        (PackageName, IO GenericPackageDescription)
-> RIO env (PackageName, IO GenericPackageDescription)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
name, RIO env GenericPackageDescription -> IO GenericPackageDescription
run (RIO env GenericPackageDescription -> IO GenericPackageDescription)
-> RIO env GenericPackageDescription
-> IO GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> RIO env GenericPackageDescription
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
pli)
  DepPackage -> RIO env DepPackage
forall (m :: * -> *) a. Monad m => a -> m a
return DepPackage :: CommonPackage
-> PackageLocation -> Bool -> FromSnapshot -> DepPackage
DepPackage
    { dpLocation :: PackageLocation
dpLocation = PackageLocation
pl
    , dpHidden :: Bool
dpHidden = Bool
False
    , dpFromSnapshot :: FromSnapshot
dpFromSnapshot = FromSnapshot
NotFromSnapshot
    , dpCommon :: CommonPackage
dpCommon = CommonPackage :: IO GenericPackageDescription
-> PackageName
-> Map FlagName Bool
-> [Text]
-> [Text]
-> Bool
-> CommonPackage
CommonPackage
                  { cpGPD :: IO GenericPackageDescription
cpGPD = IO GenericPackageDescription
gpdio
                  , cpName :: PackageName
cpName = PackageName
name
                  , cpFlags :: Map FlagName Bool
cpFlags = Map FlagName Bool
forall a. Monoid a => a
mempty
                  , cpGhcOptions :: [Text]
cpGhcOptions = [Text]
forall a. Monoid a => a
mempty
                  , cpCabalConfigOpts :: [Text]
cpCabalConfigOpts = [Text]
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 :: 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 <- RIO
  env
  (RIO env GenericPackageDescription -> IO GenericPackageDescription)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
  DepPackage -> RIO env DepPackage
forall (m :: * -> *) a. Monad m => a -> m a
return DepPackage :: CommonPackage
-> PackageLocation -> Bool -> FromSnapshot -> DepPackage
DepPackage
    { dpLocation :: PackageLocation
dpLocation = PackageLocationImmutable -> PackageLocation
PLImmutable PackageLocationImmutable
spLocation
    , dpHidden :: Bool
dpHidden = Bool
spHidden
    , dpFromSnapshot :: FromSnapshot
dpFromSnapshot = FromSnapshot
FromSnapshot
    , dpCommon :: CommonPackage
dpCommon = CommonPackage :: IO GenericPackageDescription
-> PackageName
-> Map FlagName Bool
-> [Text]
-> [Text]
-> Bool
-> CommonPackage
CommonPackage
                  { cpGPD :: IO GenericPackageDescription
cpGPD = RIO env GenericPackageDescription -> IO GenericPackageDescription
run (RIO env GenericPackageDescription -> IO GenericPackageDescription)
-> RIO env GenericPackageDescription
-> IO GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> RIO env GenericPackageDescription
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 :: CommonPackage -> m Version
loadVersion CommonPackage
common = do
    GenericPackageDescription
gpd <- IO GenericPackageDescription -> m GenericPackageDescription
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> m GenericPackageDescription)
-> IO GenericPackageDescription -> m GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ CommonPackage -> IO GenericPackageDescription
cpGPD CommonPackage
common
    Version -> m Version
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
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 (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

globalsFromDump ::
       (HasLogFunc env, HasProcessContext env)
    => GhcPkgExe
    -> RIO env (Map PackageName DumpedGlobalPackage)
globalsFromDump :: GhcPkgExe -> RIO env (Map PackageName DumpedGlobalPackage)
globalsFromDump GhcPkgExe
pkgexe = do
    let pkgConduit :: ConduitM 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) ()
-> ConduitM
     DumpedGlobalPackage c (RIO env) (Map GhcPkgId DumpedGlobalPackage)
-> ConduitM Text c (RIO env) (Map GhcPkgId DumpedGlobalPackage)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.|
            (DumpedGlobalPackage -> Map GhcPkgId DumpedGlobalPackage)
-> ConduitM
     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 -> GhcPkgId
dpGhcPkgId DumpedGlobalPackage
dp) DumpedGlobalPackage
dp)
        toGlobals :: Map k DumpedGlobalPackage -> Map PackageName DumpedGlobalPackage
toGlobals Map k DumpedGlobalPackage
ds =
          [(PackageName, DumpedGlobalPackage)]
-> Map PackageName DumpedGlobalPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, DumpedGlobalPackage)]
 -> Map PackageName DumpedGlobalPackage)
-> [(PackageName, DumpedGlobalPackage)]
-> Map PackageName DumpedGlobalPackage
forall a b. (a -> b) -> a -> b
$ (DumpedGlobalPackage -> (PackageName, DumpedGlobalPackage))
-> [DumpedGlobalPackage] -> [(PackageName, DumpedGlobalPackage)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (DumpedGlobalPackage -> PackageIdentifier)
-> DumpedGlobalPackage
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpedGlobalPackage -> PackageIdentifier
dpPackageIdent (DumpedGlobalPackage -> PackageName)
-> (DumpedGlobalPackage -> DumpedGlobalPackage)
-> DumpedGlobalPackage
-> (PackageName, DumpedGlobalPackage)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& DumpedGlobalPackage -> DumpedGlobalPackage
forall a. a -> a
id) ([DumpedGlobalPackage] -> [(PackageName, DumpedGlobalPackage)])
-> [DumpedGlobalPackage] -> [(PackageName, DumpedGlobalPackage)]
forall a b. (a -> b) -> a -> b
$ Map k DumpedGlobalPackage -> [DumpedGlobalPackage]
forall k a. Map k a -> [a]
Map.elems Map k DumpedGlobalPackage
ds
    Map GhcPkgId DumpedGlobalPackage
-> Map PackageName DumpedGlobalPackage
forall k.
Map k DumpedGlobalPackage -> Map PackageName DumpedGlobalPackage
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, HasLogFunc 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.
ConduitM Text c (RIO env) (Map GhcPkgId DumpedGlobalPackage)
pkgConduit

globalsFromHints ::
       HasConfig env
    => WantedCompiler
    -> RIO env (Map PackageName Version)
globalsFromHints :: WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints WantedCompiler
compiler = do
    Maybe (Map PackageName Version)
mglobalHints <- WantedCompiler -> RIO env (Maybe (Map PackageName Version))
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 -> Map PackageName Version -> RIO env (Map PackageName Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PackageName Version
hints
        Maybe (Map PackageName Version)
Nothing -> do
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Unable to load global hints for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> WantedCompiler -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display WantedCompiler
compiler
            Map PackageName Version -> RIO env (Map PackageName Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PackageName Version
forall a. Monoid a => a
mempty

type DumpedGlobalPackage = DumpPackage

actualFromGhc ::
       (HasConfig env, HasCompiler env)
    => SMWanted
    -> ActualCompiler
    -> RIO env (SMActual DumpedGlobalPackage)
actualFromGhc :: SMWanted
-> ActualCompiler -> RIO env (SMActual DumpedGlobalPackage)
actualFromGhc SMWanted
smw ActualCompiler
ac = do
    Map PackageName DumpedGlobalPackage
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
compilerPathsLGetting (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 CompilerPaths -> Map PackageName DumpedGlobalPackage
cpGlobalDump
    SMActual DumpedGlobalPackage
-> RIO env (SMActual DumpedGlobalPackage)
forall (m :: * -> *) a. Monad m => a -> m a
return
        SMActual :: forall global.
ActualCompiler
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> Map PackageName global
-> SMActual global
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 :: SMWanted
-> ActualCompiler -> RIO env (SMActual GlobalPackageVersion)
actualFromHints SMWanted
smw ActualCompiler
ac = do
    Map PackageName Version
globals <- WantedCompiler -> RIO env (Map PackageName Version)
forall env.
HasConfig env =>
WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints (ActualCompiler -> WantedCompiler
actualToWanted ActualCompiler
ac)
    SMActual GlobalPackageVersion
-> RIO env (SMActual GlobalPackageVersion)
forall (m :: * -> *) a. Monad m => a -> m a
return
        SMActual :: forall global.
ActualCompiler
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> Map PackageName global
-> SMActual global
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 = (Version -> GlobalPackageVersion)
-> Map PackageName Version -> Map PackageName GlobalPackageVersion
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 :: RIO env (ConfVar -> Either ConfVar Bool)
globalCondCheck = do
  Platform Arch
arch OS
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
platformL
  let condCheck :: ConfVar -> Either ConfVar Bool
condCheck (PD.OS OS
os') = Bool -> Either ConfVar Bool
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 (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
  (ConfVar -> Either ConfVar Bool)
-> RIO env (ConfVar -> Either ConfVar Bool)
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 :: 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 <-
        [(PackageName, Map FlagName Bool)]
-> ((PackageName, Map FlagName Bool) -> m (Maybe UnusedFlags))
-> m [UnusedFlags]
forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM (Map PackageName (Map FlagName Bool)
-> [(PackageName, Map FlagName Bool)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Map FlagName Bool)
packageFlags) (((PackageName, Map FlagName Bool) -> m (Maybe UnusedFlags))
 -> m [UnusedFlags])
-> ((PackageName, Map FlagName Bool) -> m (Maybe UnusedFlags))
-> m [UnusedFlags]
forall a b. (a -> b) -> a -> b
$ \(PackageName
pname, Map FlagName Bool
flags) ->
            (PackageName, Map FlagName Bool)
-> FlagSource
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> m (Maybe UnusedFlags)
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
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([UnusedFlags] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnusedFlags]
unusedFlags) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        StackBuildException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackBuildException -> m ()) -> StackBuildException -> m ()
forall a b. (a -> b) -> a -> b
$ Set UnusedFlags -> StackBuildException
InvalidFlagSpecification (Set UnusedFlags -> StackBuildException)
-> Set UnusedFlags -> StackBuildException
forall a b. (a -> b) -> a -> b
$ [UnusedFlags] -> Set UnusedFlags
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 :: (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 =
          (ProjectPackage -> CommonPackage)
-> Maybe ProjectPackage -> Maybe CommonPackage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProjectPackage -> CommonPackage
ppCommon (PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName ProjectPackage
prj) Maybe CommonPackage -> Maybe CommonPackage -> Maybe CommonPackage
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          (DepPackage -> CommonPackage)
-> Maybe DepPackage -> Maybe CommonPackage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DepPackage -> CommonPackage
dpCommon (PackageName -> Map PackageName DepPackage -> Maybe DepPackage
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 ->
            Maybe UnusedFlags -> m (Maybe UnusedFlags)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UnusedFlags -> m (Maybe UnusedFlags))
-> Maybe UnusedFlags -> m (Maybe UnusedFlags)
forall a b. (a -> b) -> a -> b
$ UnusedFlags -> Maybe UnusedFlags
forall a. a -> Maybe a
Just (UnusedFlags -> Maybe UnusedFlags)
-> UnusedFlags -> Maybe UnusedFlags
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 <- IO GenericPackageDescription -> m GenericPackageDescription
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> m GenericPackageDescription)
-> IO GenericPackageDescription -> m GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ CommonPackage -> IO GenericPackageDescription
cpGPD CommonPackage
common
            let pname :: PackageName
pname = PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
PD.packageDescription GenericPackageDescription
gpd
                pkgFlags :: Set FlagName
pkgFlags = [FlagName] -> Set FlagName
forall a. Ord a => [a] -> Set a
Set.fromList ([FlagName] -> Set FlagName) -> [FlagName] -> Set FlagName
forall a b. (a -> b) -> a -> b
$ (Flag -> FlagName) -> [Flag] -> [FlagName]
forall a b. (a -> b) -> [a] -> [b]
map Flag -> FlagName
PD.flagName ([Flag] -> [FlagName]) -> [Flag] -> [FlagName]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> [Flag]
PD.genPackageFlags GenericPackageDescription
gpd
                unused :: Set FlagName
unused = Map FlagName Bool -> Set FlagName
forall k a. Map k a -> Set k
Map.keysSet (Map FlagName Bool -> Set FlagName)
-> Map FlagName Bool -> Set FlagName
forall a b. (a -> b) -> a -> b
$ Map FlagName Bool -> Set FlagName -> Map FlagName Bool
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map FlagName Bool
userFlags Set FlagName
pkgFlags
            if Set FlagName -> Bool
forall a. Set a -> Bool
Set.null Set FlagName
unused
                    -- All flags are defined, nothing to do
                    then Maybe UnusedFlags -> m (Maybe UnusedFlags)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UnusedFlags
forall a. Maybe a
Nothing
                    -- Error about the undefined flags
                    else Maybe UnusedFlags -> m (Maybe UnusedFlags)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UnusedFlags -> m (Maybe UnusedFlags))
-> Maybe UnusedFlags -> m (Maybe UnusedFlags)
forall a b. (a -> b) -> a -> b
$ UnusedFlags -> Maybe UnusedFlags
forall a. a -> Maybe a
Just (UnusedFlags -> Maybe UnusedFlags)
-> UnusedFlags -> Maybe UnusedFlags
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) =
        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
. DumpedGlobalPackage -> PackageIdentifier
dpPackageIdent)
            DumpedGlobalPackage -> GhcPkgId
dpGhcPkgId DumpedGlobalPackage -> [GhcPkgId]
dpDepends 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
. DumpedGlobalPackage -> PackageIdentifier
dpPackageIdent) 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

getCompilerInfo :: (HasConfig env, HasCompiler env) => RIO env Builder
getCompilerInfo :: 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
compilerPathsLGetting 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 (ByteString -> Builder
byteString (ByteString -> Builder)
-> (CompilerPaths -> ByteString) -> CompilerPaths -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerPaths -> ByteString
cpGhcInfo)

immutableLocSha :: PackageLocationImmutable -> Builder
immutableLocSha :: PackageLocationImmutable -> Builder
immutableLocSha = ByteString -> Builder
byteString (ByteString -> Builder)
-> (PackageLocationImmutable -> ByteString)
-> PackageLocationImmutable
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeKey -> ByteString
treeKeyToBs (TreeKey -> ByteString)
-> (PackageLocationImmutable -> TreeKey)
-> PackageLocationImmutable
-> ByteString
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 :: RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate RawSnapshotLocation
loc PrintWarnings
printWarnings Bool
buildHaddocks = do
    (Snapshot
snapshot, [CompletedSL]
_, [CompletedPLI]
_) <- RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw RawSnapshotLocation
loc Map RawSnapshotLocation SnapshotLocation
forall k a. Map k a
Map.empty Map RawPackageLocationImmutable PackageLocationImmutable
forall k a. Map k a
Map.empty
    Map PackageName DepPackage
deps <- (PackageName -> SnapshotPackage -> RIO env DepPackage)
-> Map PackageName SnapshotPackage
-> RIO env (Map PackageName DepPackage)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (Bool -> PackageName -> SnapshotPackage -> RIO env DepPackage
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 <- (Version -> GlobalPackageVersion)
-> Map PackageName Version -> Map PackageName GlobalPackageVersion
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Version -> GlobalPackageVersion
GlobalPackageVersion (Map PackageName Version -> Map PackageName GlobalPackageVersion)
-> RIO env (Map PackageName Version)
-> RIO env (Map PackageName GlobalPackageVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WantedCompiler -> RIO env (Map PackageName Version)
forall env.
HasConfig env =>
WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints WantedCompiler
wc
    SnapshotCandidate env -> RIO env (SnapshotCandidate env)
forall (m :: * -> *) a. Monad m => a -> m a
return (SnapshotCandidate env -> RIO env (SnapshotCandidate env))
-> SnapshotCandidate env -> RIO env (SnapshotCandidate env)
forall a b. (a -> b) -> a -> b
$ \[ResolvedPath Dir]
projectPackages -> do
        Map PackageName ProjectPackage
prjPkgs <- ([(PackageName, ProjectPackage)] -> Map PackageName ProjectPackage)
-> RIO env [(PackageName, ProjectPackage)]
-> RIO env (Map PackageName ProjectPackage)
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
            ProjectPackage
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
            (PackageName, ProjectPackage)
-> RIO env (PackageName, ProjectPackage)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommonPackage -> PackageName
cpName (CommonPackage -> PackageName) -> CommonPackage -> PackageName
forall a b. (a -> b) -> a -> b
$ ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp, ProjectPackage
pp)
        ActualCompiler
compiler <- (CompilerException -> RIO env ActualCompiler)
-> (ActualCompiler -> RIO env ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO env ActualCompiler
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerException -> RIO env ActualCompiler
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ActualCompiler -> RIO env ActualCompiler
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CompilerException ActualCompiler -> RIO env ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO env ActualCompiler
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual
                  (WantedCompiler -> Either CompilerException ActualCompiler)
-> WantedCompiler -> Either CompilerException ActualCompiler
forall a b. (a -> b) -> a -> b
$ Snapshot -> WantedCompiler
snapshotCompiler Snapshot
snapshot
        SMActual GlobalPackageVersion
-> RIO env (SMActual GlobalPackageVersion)
forall (m :: * -> *) a. Monad m => a -> m a
return SMActual :: forall global.
ActualCompiler
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> Map PackageName global
-> SMActual global
SMActual
              { smaCompiler :: ActualCompiler
smaCompiler = ActualCompiler
compiler
              , smaProject :: Map PackageName ProjectPackage
smaProject = Map PackageName ProjectPackage
prjPkgs
              , smaDeps :: Map PackageName DepPackage
smaDeps = Map PackageName DepPackage
-> Map PackageName ProjectPackage -> Map PackageName DepPackage
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
              }