From fc95fb5d0ab9f10f8d3e144cfd9ab0ba60c9c7f8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 20 Mar 2019 13:07:18 +0200 Subject: [PATCH] Introduce the HasCompiler typeclass (fixes #4639) There may be additional places where the typeclass needs to be added as a constraint, I don't claim to have found all cases. --- src/Stack/Build/ConstructPlan.hs | 1 + src/Stack/Build/Execute.hs | 2 +- src/Stack/Build/Source.hs | 2 +- src/Stack/BuildPlan.hs | 8 ++-- src/Stack/GhcPkg.hs | 15 ++++---- src/Stack/Init.hs | 6 +-- src/Stack/PackageDump.hs | 7 ++-- src/Stack/Setup.hs | 64 +++++++++++++++++++++++-------- src/Stack/Snapshot.hs | 56 +++++++++++++++++---------- src/Stack/Solver.hs | 25 +++++------- src/Stack/SourceMap.hs | 4 +- src/Stack/Types/Config.hs | 10 ++++- src/test/Stack/PackageDumpSpec.hs | 5 ++- 13 files changed, 130 insertions(+), 75 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 15ab950c48..1d2b5e7434 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -147,6 +147,7 @@ instance HasProcessContext Ctx where instance HasBuildConfig Ctx instance HasSourceMap Ctx where sourceMapL = envConfigL.sourceMapL +instance HasCompiler Ctx instance HasEnvConfig Ctx where envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index eb8f5ed944..eefc5e9b6e 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -656,7 +656,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do $ planUnregisterLocal plan unregisterPackages :: - (HasProcessContext env, HasLogFunc env, HasPlatform env) + (HasProcessContext env, HasLogFunc env, HasPlatform env, HasCompiler env) => ActualCompiler -> Path Abs Dir -> NonEmpty (GhcPkgId, (PackageIdentifier, Text)) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 3730d2bd9b..3541fea4d6 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -137,7 +137,7 @@ loadSourceMap smt boptsCli sma = do -- * Make sure things like profiling and haddocks are included in the hash -- hashSourceMapData - :: HasBuildConfig env + :: (HasBuildConfig env, HasCompiler env) => BuildOptsCLI -> SourceMap -> RIO env SourceMapHash diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index b74888c9e6..d0f2acd16e 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -338,11 +338,11 @@ checkSnapBuildPlan => [GenericPackageDescription] -> Maybe (Map PackageName (Map FlagName Bool)) -> SnapshotDef - -> Maybe ActualCompiler + -> (SnapshotDef -> RIO env LoadedSnapshot) -> RIO env BuildPlanCheck -checkSnapBuildPlan gpds flags snapshotDef mactualCompiler = do +checkSnapBuildPlan gpds flags snapshotDef loadSnapshot = do platform <- view platformL - rs <- loadSnapshot mactualCompiler snapshotDef + rs <- loadSnapshot snapshotDef let compiler = lsCompilerVersion rs @@ -391,7 +391,7 @@ selectBestSnapshot gpds snaps = do getResult snap = do result <- checkSnapBuildPlan gpds Nothing snap -- Rely on global package hints. - Nothing + loadSnapshotGlobalHints reportResult result snap return (snap, result) diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 7996eb6331..1ba2430dbc 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -29,13 +29,14 @@ import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Stack.Constants import Stack.Types.Build +import Stack.Types.Config (HasCompiler) import Stack.Types.GhcPkgId import Stack.Types.Compiler import System.FilePath (searchPathSeparator) import RIO.Process -- | Get the global package database -getGlobalDB :: (HasProcessContext env, HasLogFunc env) +getGlobalDB :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => WhichCompiler -> RIO env (Path Abs Dir) getGlobalDB wc = do logDebug "Getting global package database location" @@ -52,7 +53,7 @@ getGlobalDB wc = do firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n') -- | Run the ghc-pkg executable -ghcPkg :: (HasProcessContext env, HasLogFunc env) +ghcPkg :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => WhichCompiler -> [Path Abs Dir] -> [String] @@ -72,7 +73,7 @@ ghcPkg wc pkgDbs args = do -- | Create a package database in the given directory, if it doesn't exist. createDatabase - :: (HasProcessContext env, HasLogFunc env) + :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => WhichCompiler -> Path Abs Dir -> RIO env () createDatabase wc db = do exists <- doesFileExist (db relFilePackageCache) @@ -117,7 +118,7 @@ packageDbFlags pkgDbs = -- | Get the value of a field of the package. findGhcPkgField - :: (HasProcessContext env, HasLogFunc env) + :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => WhichCompiler -> [Path Abs Dir] -- ^ package databases -> String -- ^ package identifier, or GhcPkgId @@ -136,7 +137,7 @@ findGhcPkgField wc pkgDbs name field = do fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs -- | Get the version of the package -findGhcPkgVersion :: (HasProcessContext env, HasLogFunc env) +findGhcPkgVersion :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => WhichCompiler -> [Path Abs Dir] -- ^ package databases -> PackageName @@ -149,7 +150,7 @@ findGhcPkgVersion wc pkgDbs name = do -- | unregister list of package ghcids, batching available from GHC 8.0.1, -- using GHC package id where available (from GHC 7.9) -unregisterGhcPkgIds :: (HasProcessContext env, HasLogFunc env) +unregisterGhcPkgIds :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => WhichCompiler -> Path Abs Dir -- ^ package database -> NonEmpty (Either PackageIdentifier GhcPkgId) @@ -167,7 +168,7 @@ unregisterGhcPkgIds wc pkgDb epgids = do epgids -- | Get the version of Cabal from the global package database. -getCabalPkgVer :: (HasProcessContext env, HasLogFunc env) +getCabalPkgVer :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => WhichCompiler -> RIO env Version getCabalPkgVer wc = do logDebug "Getting Cabal package version" diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 8726b1c7e4..e8e07338a3 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -34,7 +34,7 @@ import Stack.BuildPlan import Stack.Config (getSnapshots, makeConcreteResolver) import Stack.Constants -import Stack.Snapshot (loadResolver) +import Stack.Snapshot (loadResolver, loadSnapshotGlobalHints) import Stack.Solver import Stack.Types.Build import Stack.Types.BuildPlan @@ -426,7 +426,7 @@ checkBundleResolver (Either [PackageName] ( Map PackageName (Map FlagName Bool) , Map PackageName Version)) checkBundleResolver whichCmd initOpts bundle sd = do - result <- checkSnapBuildPlan gpds Nothing sd Nothing + result <- checkSnapBuildPlan gpds Nothing sd loadSnapshotGlobalHints case result of BuildPlanCheckOk f -> return $ Right (f, Map.empty) BuildPlanCheckPartial f e -> do @@ -485,7 +485,7 @@ checkBundleResolver whichCmd initOpts bundle sd = do -- set of packages. findOneIndependent packages flags = do platform <- view platformL - (compiler, _) <- getResolverConstraints Nothing sd + (compiler, _) <- getResolverConstraints <$> loadSnapshotGlobalHints sd let getGpd pkg = snd (fromMaybe (error "findOneIndependent: getGpd") (Map.lookup pkg bundle)) getFlags pkg = fromMaybe (error "fromOneIndependent: getFlags") (Map.lookup pkg flags) deps pkg = gpdPackageDeps (getGpd pkg) compiler platform diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 1427c645bf..6185e284bb 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -31,12 +31,13 @@ import qualified Distribution.Text as C import Path.Extra (toFilePathNoTrailingSep) import Stack.GhcPkg import Stack.Types.Compiler +import Stack.Types.Config (HasCompiler) import Stack.Types.GhcPkgId import RIO.Process hiding (readProcess) -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump - :: (HasProcessContext env, HasLogFunc env) + :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global -> ConduitM Text Void (RIO env) a @@ -45,7 +46,7 @@ ghcPkgDump = ghcPkgCmdArgs ["dump"] -- | Call ghc-pkg describe with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDescribe - :: (HasProcessContext env, HasLogFunc env) + :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => PackageName -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global @@ -55,7 +56,7 @@ ghcPkgDescribe pkgName' = ghcPkgCmdArgs ["describe", "--simple-output", packageN -- | Call ghc-pkg and stream to the given @Sink@, for a single database ghcPkgCmdArgs - :: (HasProcessContext env, HasLogFunc env) + :: (HasProcessContext env, HasLogFunc env, HasCompiler env) => [String] -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 6e66064545..863e857f07 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -32,6 +32,9 @@ module Stack.Setup , preferredPlatforms , downloadStackReleaseInfo , downloadStackExe + -- * WithGHC + , WithGHC (..) + , runWithGHC ) where import qualified Codec.Archive.Tar as Tar @@ -211,11 +214,10 @@ instance Show SetupException where "I don't know how to install GHC on your system configuration, please install manually" -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too -setupEnv :: (HasBuildConfig env, HasGHCVariant env) - => NeedTargets +setupEnv :: NeedTargets -> BuildOptsCLI -> Maybe Text -- ^ Message to give user when necessary GHC is not available - -> RIO env EnvConfig + -> RIO BuildConfig EnvConfig setupEnv needTargets boptsCLI mResolveMissingGHC = do config <- view configL bc <- view buildConfigL @@ -250,21 +252,14 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do (view envVarsL menv0) menv <- mkProcessContext env - -- FIXME currently this fails with SkipDownloadcompiler - (compilerVer, cabalVer, globaldb) <- withProcessContext menv $ runConcurrently $ (,,) + (compilerVer, cabalVer, globaldb) <- runWithGHC menv $ runConcurrently $ (,,) <$> Concurrently (getCompilerVersion wc) <*> Concurrently (getCabalPkgVer wc) <*> Concurrently (getGlobalDB wc) logDebug "Resolving package entries" - -- Set up a modified environment which includes the modified PATH - -- that GHC can be found on. This is needed for looking up global - -- package information and ghc fingerprint (result from 'ghc --info'). - let bcPath :: BuildConfig - bcPath = set envOverrideSettingsL (\_ -> return menv) $ - set processContextL menv bc - (sourceMap, sourceMapHash) <- runRIO bcPath $ do + (sourceMap, sourceMapHash) <- runWithGHC menv $ do smActual <- actualFromGhc (bcSMWanted bc) compilerVer let actualPkgs = Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual) @@ -291,9 +286,9 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do localsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs True) mpath deps <- runRIO envConfig0 packageDatabaseDeps - withProcessContext menv $ createDatabase wc deps + runWithGHC menv $ createDatabase wc deps localdb <- runRIO envConfig0 packageDatabaseLocal - withProcessContext menv $ createDatabase wc localdb + runWithGHC menv $ createDatabase wc localdb extras <- runReaderT packageDatabaseExtra envConfig0 let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb @@ -372,6 +367,45 @@ setupEnv needTargets boptsCLI mResolveMissingGHC = do , envConfigCompilerBuild = mCompilerBuild } +-- | A modified env which we know has an installed compiler on the PATH. +newtype WithGHC env = WithGHC env + +insideL :: Lens' (WithGHC env) env +insideL = lens (\(WithGHC x) -> x) (\_ -> WithGHC) + +instance HasLogFunc env => HasLogFunc (WithGHC env) where + logFuncL = insideL.logFuncL +instance HasRunner env => HasRunner (WithGHC env) where + runnerL = insideL.runnerL +instance HasProcessContext env => HasProcessContext (WithGHC env) where + processContextL = insideL.processContextL +instance HasStylesUpdate env => HasStylesUpdate (WithGHC env) where + stylesUpdateL = insideL.stylesUpdateL +instance HasTerm env => HasTerm (WithGHC env) where + useColorL = insideL.useColorL + termWidthL = insideL.termWidthL +instance HasPantryConfig env => HasPantryConfig (WithGHC env) where + pantryConfigL = insideL.pantryConfigL +instance HasConfig env => HasPlatform (WithGHC env) +instance HasConfig env => HasGHCVariant (WithGHC env) +instance HasConfig env => HasConfig (WithGHC env) where + configL = insideL.configL +instance HasBuildConfig env => HasBuildConfig (WithGHC env) where + buildConfigL = insideL.buildConfigL +instance HasCompiler (WithGHC env) + +-- | Set up a modified environment which includes the modified PATH +-- that GHC can be found on. This is needed for looking up global +-- package information and ghc fingerprint (result from 'ghc --info'). +runWithGHC :: HasConfig env => ProcessContext -> RIO (WithGHC env) a -> RIO env a +runWithGHC pc inner = do + env <- ask + let envg + = WithGHC $ + set envOverrideSettingsL (\_ -> return pc) $ + set processContextL pc env + runRIO envg inner + -- | special helper for GHCJS which needs an updated source map -- only project dependencies should get included otherwise source map hash will -- get changed and EnvConfig will become inconsistent @@ -383,7 +417,7 @@ rebuildEnv :: EnvConfig rebuildEnv envConfig needTargets haddockDeps boptsCLI = do let bc = envConfigBuildConfig envConfig compilerVer = smCompiler $ envConfigSourceMap envConfig - runRIO bc $ do + runRIO (WithGHC bc) $ do smActual <- actualFromGhc (bcSMWanted bc) compilerVer let actualPkgs = Map.keysSet (smaDeps smActual) <> Map.keysSet (smaProject smActual) prunedActual = smActual { diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index fa50b8e9c5..b99a0ca816 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -12,7 +12,8 @@ -- @LoadedSnapshot@s. module Stack.Snapshot ( loadResolver - , loadSnapshot + , loadSnapshotCompiler + , loadSnapshotGlobalHints , calculatePackagePromotion ) where @@ -152,14 +153,45 @@ loadResolver rsl mcompiler = do combineHashes :: SHA256 -> SHA256 -> SHA256 combineHashes x y = SHA256.hashBytes (SHA256.toRaw x <> SHA256.toRaw y) +-- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' using an installed compiler +loadSnapshotCompiler + :: forall env. + (HasConfig env, HasGHCVariant env, HasCompiler env) + => ActualCompiler + -> SnapshotDef + -> RIO env LoadedSnapshot +loadSnapshotCompiler compiler = loadSnapshot (Just compiler) (\_wanted -> loadCompiler compiler) + +-- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' using global hints +loadSnapshotGlobalHints + :: forall env. + (HasConfig env, HasGHCVariant env) + => SnapshotDef + -> RIO env LoadedSnapshot +loadSnapshotGlobalHints = loadSnapshot Nothing $ \wanted -> do + ghfp <- globalHintsFile + mglobalHints <- loadGlobalHints ghfp wanted + globalHints <- + case mglobalHints of + Just x -> pure x + Nothing -> do + logWarn $ "Unable to load global hints for " <> RIO.display wanted + pure mempty + return LoadedSnapshot + { lsCompilerVersion = wantedToActual wanted + , lsGlobals = fromGlobalHints globalHints + , lsPackages = Map.empty + } + -- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' loadSnapshot :: forall env. (HasConfig env, HasGHCVariant env) => Maybe ActualCompiler -- ^ installed GHC we should query; if none provided, use the global hints + -> (WantedCompiler -> RIO env LoadedSnapshot) -> SnapshotDef -> RIO env LoadedSnapshot -loadSnapshot mcompiler = +loadSnapshot mcompiler helper = start where start sd = do @@ -172,23 +204,7 @@ loadSnapshot mcompiler = inner sd = do logInfo $ "Loading a snapshot from a SnapshotDef: " <> RIO.display (sdResolverName sd) case sdSnapshot sd of - Nothing -> - case mcompiler of - Nothing -> do - ghfp <- globalHintsFile - mglobalHints <- loadGlobalHints ghfp (sdWantedCompilerVersion sd) - globalHints <- - case mglobalHints of - Just x -> pure x - Nothing -> do - logWarn $ "Unable to load global hints for " <> RIO.display (sdWantedCompilerVersion sd) - pure mempty - return LoadedSnapshot - { lsCompilerVersion = wantedToActual $ sdWantedCompilerVersion sd - , lsGlobals = fromGlobalHints globalHints - , lsPackages = Map.empty - } - Just cv' -> loadCompiler cv' + Nothing -> helper (sdWantedCompilerVersion sd) Just (snapshot, sd') -> start sd' >>= inner2 snapshot inner2 snap ls0 = do @@ -394,7 +410,7 @@ checkDepsMet available m -- | Load a snapshot from the given compiler version, using just the -- information in the global package database. loadCompiler :: forall env. - HasConfig env + (HasConfig env, HasCompiler env) => ActualCompiler -> RIO env LoadedSnapshot loadCompiler cv = do diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 5dfc7f4558..e8f7911a3a 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -49,7 +49,7 @@ import Stack.Config (loadConfigYaml) import Stack.Constants (stackDotYaml, wiredInPackages) import Stack.Setup import Stack.Setup.Installed -import Stack.Snapshot (loadSnapshot) +import Stack.Snapshot (loadSnapshotCompiler) import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Compiler @@ -280,7 +280,7 @@ setupCompiler compiler = do setupCabalEnv :: (HasConfig env, HasGHCVariant env) => WantedCompiler - -> (ActualCompiler -> RIO env a) + -> (ActualCompiler -> RIO (WithGHC env) a) -> RIO env a setupCabalEnv compiler inner = do mpaths <- setupCompiler compiler @@ -289,7 +289,7 @@ setupCabalEnv compiler inner = do $ augmentPathMap (toFilePath <$> maybe [] edBins mpaths) (view envVarsL menv0) menv <- mkProcessContext envMap - withProcessContext menv $ do + runWithGHC menv $ do mcabal <- getCabalInstallVersion case mcabal of Nothing -> throwM SolverMissingCabalInstall @@ -361,7 +361,7 @@ solveResolverSpec cabalDirs logInfo $ "Using resolver: " <> RIO.display (sdResolverName sd) let wantedCompilerVersion = sdWantedCompilerVersion sd setupCabalEnv wantedCompilerVersion $ \compilerVersion -> do - (compilerVer, snapConstraints) <- getResolverConstraints (Just compilerVersion) sd + (compilerVer, snapConstraints) <- getResolverConstraints <$> loadSnapshotCompiler compilerVersion sd let -- Note - The order in Map.union below is important. -- We want to override snapshot with extra deps @@ -461,18 +461,13 @@ solveResolverSpec cabalDirs -- return the compiler version, package versions and packages flags -- for that resolver. getResolverConstraints - :: (HasConfig env, HasGHCVariant env) - => Maybe ActualCompiler -- ^ actually installed compiler - -> SnapshotDef - -> RIO env - (ActualCompiler, - Map PackageName (Version, Map FlagName Bool)) -getResolverConstraints mcompilerVersion sd = do - ls <- loadSnapshot mcompilerVersion sd - return (lsCompilerVersion ls, lsConstraints ls) + :: LoadedSnapshot + -> (ActualCompiler, Map PackageName (Version, Map FlagName Bool)) +getResolverConstraints ls = + (lsCompilerVersion ls, lsConstraints) where lpiConstraints lpi = (lpiVersion lpi, lpiFlags lpi) - lsConstraints ls = Map.union + lsConstraints = Map.union (Map.map lpiConstraints (lsPackages ls)) (Map.map lpiConstraints (lsGlobals ls)) @@ -641,7 +636,7 @@ solveExtraDeps modStackYaml = do extraConstraints = mergeConstraints oldExtraVersions oldExtraFlags actualCompiler <- view actualCompilerVersionL - resolverResult <- checkSnapBuildPlan gpds (Just oldSrcFlags) sd (Just actualCompiler) + resolverResult <- checkSnapBuildPlan gpds (Just oldSrcFlags) sd (loadSnapshotCompiler actualCompiler) resultSpecs <- case resolverResult of BuildPlanCheckOk flags -> return $ Just (mergeConstraints oldSrcs flags, Map.empty) diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index 7302826436..72232ac984 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -119,7 +119,7 @@ getPLIVersion (PLIArchive _ pm) = pkgVersion $ pmIdent pm getPLIVersion (PLIRepo _ pm) = pkgVersion $ pmIdent pm globalsFromDump :: - (HasLogFunc env, HasProcessContext env) + (HasLogFunc env, HasProcessContext env, HasCompiler env) => ActualCompiler -> RIO env (Map PackageName DumpedGlobalPackage) globalsFromDump compiler = do @@ -146,7 +146,7 @@ globalsFromHints compiler = do type DumpedGlobalPackage = DumpPackage actualFromGhc :: - (HasConfig env) + (HasConfig env, HasCompiler env) => SMWanted -> ActualCompiler -> RIO env (SMActual DumpedGlobalPackage) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index f50eed809b..fcb20984ab 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -145,6 +145,7 @@ module Stack.Types.Config -- * Lens helpers ,wantedCompilerVersionL ,actualCompilerVersionL + ,HasCompiler ,buildOptsL ,globalOptsL ,buildOptsInstallExesL @@ -1440,7 +1441,7 @@ plainEnvSettings = EnvSettings -- -- https://github.com/commercialhaskell/stack/issues/1052 getCompilerPath - :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env) + :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasCompiler env) => WhichCompiler -> m (Path Abs File) getCompilerPath wc = do @@ -1819,7 +1820,7 @@ class HasConfig env => HasBuildConfig env where envConfigBuildConfig (\x y -> x { envConfigBuildConfig = y }) -class (HasBuildConfig env, HasSourceMap env) => HasEnvConfig env where +class (HasBuildConfig env, HasSourceMap env, HasCompiler env) => HasEnvConfig env where envConfigL :: Lens' env EnvConfig ----------------------------------- @@ -1869,6 +1870,7 @@ instance HasBuildConfig BuildConfig where {-# INLINE buildConfigL #-} instance HasBuildConfig EnvConfig +instance HasCompiler EnvConfig instance HasEnvConfig EnvConfig where envConfigL = id {-# INLINE envConfigL #-} @@ -1916,6 +1918,10 @@ stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y }) wantedCompilerVersionL :: HasBuildConfig s => Getting r s WantedCompiler wantedCompilerVersionL = buildConfigL.to (smwCompiler . bcSMWanted) +-- | An environment which ensures that the given compiler is available +-- on the PATH. This class is used for the type alone, and has no methods. +class HasCompiler env + class HasSourceMap env where sourceMapL :: Lens' env SourceMap instance HasSourceMap EnvConfig where diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index fae5741f40..ca65b1392d 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -13,6 +13,7 @@ import Distribution.Types.PackageName (mkPackageName) import Distribution.Version (mkVersion) import Stack.PackageDump import Stack.Prelude +import Stack.Setup import Stack.Types.Compiler import Stack.Types.GhcPkgId import RIO.Process @@ -259,8 +260,8 @@ checkDepsPresent prunes selected = Nothing -> error "checkDepsPresent: missing in depMap" Just deps -> Set.null $ Set.difference (Set.fromList deps) allIds -runEnvNoLogging :: RIO LoggedProcessContext a -> IO a +runEnvNoLogging :: RIO (WithGHC LoggedProcessContext) a -> IO a runEnvNoLogging inner = do envVars <- view envVarsL <$> mkDefaultProcessContext menv <- mkProcessContext $ Map.delete "GHC_PACKAGE_PATH" envVars - runRIO (LoggedProcessContext menv mempty) inner + runRIO (WithGHC (LoggedProcessContext menv mempty)) inner