Merge pull request #3609 from commercialhaskell/3607-stack-init-solver

Ensure updated EnvOverride when using stack init --solver

src/Stack/Build.hs

@@ -278,12 +278,11 @@ withLoadPackage :: HasEnvConfig env
                 -> RIO env a
 withLoadPackage inner = do
     econfig <- view envConfigL
-    menv <- getMinimalEnvOverride
     root <- view projectRootL
     run <- askRunInIO
     withCabalLoader $ \loadFromIndex ->
         inner $ \loc flags ghcOptions -> do
-            bs <- run $ loadSingleRawCabalFile loadFromIndex menv root loc
+            bs <- run $ loadSingleRawCabalFile loadFromIndex root loc
 
             -- Intentionally ignore warnings, as it's not really
             -- appropriate to print a bunch of warnings out while

src/Stack/Build/Source.hs

@@ -95,9 +95,8 @@ loadSourceMapFull needTargets boptsCli = do
             PLIndex pir -> return $ PSIndex loc (lpiFlags lpi) configOpts pir
             PLOther pl -> do
               -- FIXME lots of code duplication with getLocalPackages
-              menv <- getMinimalEnvOverride
               root <- view projectRootL
-              dir <- resolveSinglePackageLocation menv root pl
+              dir <- resolveSinglePackageLocation root pl
               cabalfp <- findOrGenerateCabalFile dir
               bs <- liftIO (S.readFile (toFilePath cabalfp))
               (warnings, gpd) <-

src/Stack/Build/Target.hs

@@ -493,7 +493,6 @@ parseTargets needTargets boptscli = do
           ["The specified targets matched no packages"]
 
   root <- view projectRootL
-  menv <- getMinimalEnvOverride
 
   let dropMaybeKey (Nothing, _) = Map.empty
       dropMaybeKey (Just key, value) = Map.singleton key value
@@ -513,7 +512,7 @@ parseTargets needTargets boptscli = do
 
   (globals', snapshots, locals') <- withCabalLoader $ \loadFromIndex -> do
     addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do
-      bs <- loadSingleRawCabalFile loadFromIndex menv root loc
+      bs <- loadSingleRawCabalFile loadFromIndex root loc
       case rawParseGPD bs of
         Left e -> throwIO $ InvalidCabalFileInLocal loc e bs
         Right (_warnings, gpd) -> return (name, (gpd, loc, Nothing))
@@ -536,7 +535,7 @@ parseTargets needTargets boptscli = do
           ]
 
     calculatePackagePromotion
-      loadFromIndex menv root ls0 (Map.elems allLocals)
+      loadFromIndex root ls0 (Map.elems allLocals)
       flags hides options drops
 
   let ls = LoadedSnapshot

src/Stack/BuildPlan.hs

@@ -400,8 +400,7 @@ checkSnapBuildPlan
     -> RIO env BuildPlanCheck
 checkSnapBuildPlan root gpds flags snapshotDef mactualCompiler = do
     platform <- view platformL
-    menv <- getMinimalEnvOverride
-    rs <- loadSnapshot menv mactualCompiler root snapshotDef
+    rs <- loadSnapshot mactualCompiler root snapshotDef
 
     let
         compiler = lsCompilerVersion rs

src/Stack/Config.hs

@@ -652,12 +652,11 @@ getLocalPackages = do
     case mcached of
         Just cached -> return cached
         Nothing -> withCabalLoader $ \loadFromIndex -> do
-            menv <- getMinimalEnvOverride
             root <- view projectRootL
             bc <- view buildConfigL
 
             packages <- do
-              bss <- concat <$> mapM (loadMultiRawCabalFiles menv root) (bcPackages bc)
+              bss <- concat <$> mapM (loadMultiRawCabalFiles root) (bcPackages bc)
               forM bss $ \(bs, loc) -> do
                 (warnings, gpd) <-
                   case rawParseGPD bs of
@@ -667,7 +666,7 @@ getLocalPackages = do
                            fromCabalPackageIdentifier
                          $ C.package
                          $ C.packageDescription gpd
-                dir <- resolveSinglePackageLocation menv root loc
+                dir <- resolveSinglePackageLocation root loc
                 cabalfp <- findOrGenerateCabalFile dir
                 mapM_ (printCabalFileWarning cabalfp) warnings
                 checkCabalFileName name cabalfp
@@ -681,7 +680,7 @@ getLocalPackages = do
                       }
                 return (name, lpv)
 
-            deps <- mapM (loadMultiRawCabalFilesIndex loadFromIndex menv root) (bcDependencies bc)
+            deps <- mapM (loadMultiRawCabalFilesIndex loadFromIndex root) (bcDependencies bc)
                 >>= mapM (\(bs, loc :: PackageLocationIndex FilePath) -> do
                      (_warnings, gpd) <- do
                        case rawParseGPD bs of

src/Stack/Init.hs

@@ -490,8 +490,7 @@ checkBundleResolver whichCmd stackYaml initOpts bundle sd = do
       -- set of packages.
       findOneIndependent packages flags = do
           platform <- view platformL
-          menv <- getMinimalEnvOverride
-          (compiler, _) <- getResolverConstraints menv Nothing stackYaml sd
+          (compiler, _) <- getResolverConstraints Nothing stackYaml 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

src/Stack/PackageLocation.hs

@@ -43,12 +43,11 @@ import System.Process.Run
 -- 'SinglePackageLocation'.
 resolveSinglePackageLocation
     :: HasConfig env
-    => EnvOverride
-    -> Path Abs Dir -- ^ project root
+    => Path Abs Dir -- ^ project root
     -> PackageLocation FilePath
     -> RIO env (Path Abs Dir)
-resolveSinglePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp
-resolveSinglePackageLocation _ projRoot (PLArchive (Archive url subdir msha)) = do
+resolveSinglePackageLocation projRoot (PLFilePath fp) = resolveDir projRoot fp
+resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = do
     workDir <- view workDirL
 
         -- TODO: dedupe with code for snapshot hash?
@@ -135,8 +134,8 @@ resolveSinglePackageLocation _ projRoot (PLArchive (Archive url subdir msha)) =
             ignoringAbsence (removeFile fileDownload)
             ignoringAbsence (removeDirRecur dir)
             throwIO $ UnexpectedArchiveContents dirs files
-resolveSinglePackageLocation menv projRoot (PLRepo (Repo url commit repoType' subdir)) =
-    cloneRepo menv projRoot url commit repoType' >>= flip resolveDir subdir
+resolveSinglePackageLocation projRoot (PLRepo (Repo url commit repoType' subdir)) =
+    cloneRepo projRoot url commit repoType' >>= flip resolveDir subdir
 
 -- | Resolve a PackageLocation into a path, downloading and cloning as
 -- necessary.
@@ -145,24 +144,23 @@ resolveSinglePackageLocation menv projRoot (PLRepo (Repo url commit repoType' su
 -- (if relevant).
 resolveMultiPackageLocation
     :: HasConfig env
-    => EnvOverride
-    -> Path Abs Dir -- ^ project root
+    => Path Abs Dir -- ^ project root
     -> PackageLocation Subdirs
     -> RIO env [(Path Abs Dir, PackageLocation FilePath)]
-resolveMultiPackageLocation x y (PLFilePath fp) = do
-  dir <- resolveSinglePackageLocation x y (PLFilePath fp)
+resolveMultiPackageLocation y (PLFilePath fp) = do
+  dir <- resolveSinglePackageLocation y (PLFilePath fp)
   return [(dir, PLFilePath fp)]
-resolveMultiPackageLocation x y (PLArchive (Archive url subdirs msha)) = do
-  dir <- resolveSinglePackageLocation x y (PLArchive (Archive url "." msha))
+resolveMultiPackageLocation y (PLArchive (Archive url subdirs msha)) = do
+  dir <- resolveSinglePackageLocation y (PLArchive (Archive url "." msha))
   let subdirs' =
         case subdirs of
           DefaultSubdirs -> ["."]
           ExplicitSubdirs subs -> subs
   forM subdirs' $ \subdir -> do
     dir' <- resolveDir dir subdir
     return (dir', PLArchive (Archive url subdir msha))
-resolveMultiPackageLocation menv projRoot (PLRepo (Repo url commit repoType' subdirs)) = do
-  dir <- cloneRepo menv projRoot url commit repoType'
+resolveMultiPackageLocation projRoot (PLRepo (Repo url commit repoType' subdirs)) = do
+  dir <- cloneRepo projRoot url commit repoType'
 
   let subdirs' =
         case subdirs of
@@ -174,13 +172,12 @@ resolveMultiPackageLocation menv projRoot (PLRepo (Repo url commit repoType' sub
 
 cloneRepo
     :: HasConfig env
-    => EnvOverride
-    -> Path Abs Dir -- ^ project root
+    => Path Abs Dir -- ^ project root
     -> Text -- ^ URL
     -> Text -- ^ commit
     -> RepoType
     -> RIO env (Path Abs Dir)
-cloneRepo menv projRoot url commit repoType' = do
+cloneRepo projRoot url commit repoType' = do
     workDir <- view workDirL
     let nameBeforeHashing = case repoType' of
             RepoGit -> T.unwords [url, commit]
@@ -195,6 +192,7 @@ cloneRepo menv projRoot url commit repoType' = do
     exists <- doesDirExist dir
     unless exists $ do
         liftIO $ ignoringAbsence (removeDirRecur dir)
+        menv <- getMinimalEnvOverride
 
         let cloneAndExtract commandName cloneArgs resetCommand = do
                 ensureDir root
@@ -232,16 +230,15 @@ loadSingleRawCabalFile
   :: forall env.
      HasConfig env
   => (PackageIdentifierRevision -> IO ByteString) -- ^ lookup in index
-  -> EnvOverride
   -> Path Abs Dir -- ^ project root, used for checking out necessary files
   -> PackageLocationIndex FilePath
   -> RIO env ByteString
 -- Need special handling of PLIndex for efficiency (just read from the
 -- index tarball) and correctness (get the cabal file from the index,
 -- not the package tarball itself, yay Hackage revisions).
-loadSingleRawCabalFile loadFromIndex _ _ (PLIndex pir) = liftIO $ loadFromIndex pir
-loadSingleRawCabalFile _ menv root (PLOther loc) =
-  resolveSinglePackageLocation menv root loc >>=
+loadSingleRawCabalFile loadFromIndex _ (PLIndex pir) = liftIO $ loadFromIndex pir
+loadSingleRawCabalFile _ root (PLOther loc) =
+  resolveSinglePackageLocation root loc >>=
   findOrGenerateCabalFile >>=
   liftIO . S.readFile . toFilePath
 
@@ -250,18 +247,17 @@ loadMultiRawCabalFilesIndex
   :: forall env.
      HasConfig env
   => (PackageIdentifierRevision -> IO ByteString) -- ^ lookup in index
-  -> EnvOverride
   -> Path Abs Dir -- ^ project root, used for checking out necessary files
   -> PackageLocationIndex Subdirs
   -> RIO env [(ByteString, PackageLocationIndex FilePath)]
 -- Need special handling of PLIndex for efficiency (just read from the
 -- index tarball) and correctness (get the cabal file from the index,
 -- not the package tarball itself, yay Hackage revisions).
-loadMultiRawCabalFilesIndex loadFromIndex _ _ (PLIndex pir) = do
+loadMultiRawCabalFilesIndex loadFromIndex _ (PLIndex pir) = do
   bs <- liftIO $ loadFromIndex pir
   return [(bs, PLIndex pir)]
-loadMultiRawCabalFilesIndex _ x y (PLOther z) =
-  map (second PLOther) <$> loadMultiRawCabalFiles x y z
+loadMultiRawCabalFilesIndex _ y (PLOther z) =
+  map (second PLOther) <$> loadMultiRawCabalFiles y z
 
 -- | Same as 'loadSingleRawCabalFile', but for 'PackageLocation' There
 -- may be multiple results if dealing with a repository with subdirs,
@@ -270,12 +266,11 @@ loadMultiRawCabalFilesIndex _ x y (PLOther z) =
 loadMultiRawCabalFiles
   :: forall env.
      HasConfig env
-  => EnvOverride
-  -> Path Abs Dir -- ^ project root, used for checking out necessary files
+  => Path Abs Dir -- ^ project root, used for checking out necessary files
   -> PackageLocation Subdirs
   -> RIO env [(ByteString, PackageLocation FilePath)]
-loadMultiRawCabalFiles menv root loc =
-    resolveMultiPackageLocation menv root loc >>= mapM go
+loadMultiRawCabalFiles root loc =
+    resolveMultiPackageLocation root loc >>= mapM go
   where
     go (dir, loc') = do
       cabalFile <- findOrGenerateCabalFile dir

src/Stack/SDist.hs

@@ -427,10 +427,9 @@ buildExtractedTarball :: HasEnvConfig env => Path Abs Dir -> RIO env ()
 buildExtractedTarball pkgDir = do
   projectRoot <- view projectRootL
   envConfig <- view envConfigL
-  menv <- getMinimalEnvOverride
   localPackageToBuild <- readLocalPackage pkgDir
   let packageEntries = bcPackages (envConfigBuildConfig envConfig)
-      getPaths = resolveMultiPackageLocation menv projectRoot
+      getPaths = resolveMultiPackageLocation projectRoot
   allPackagePaths <- fmap (map fst . mconcat) (mapM getPaths packageEntries)
   -- We remove the path based on the name of the package
   let isPathToRemove path = do

src/Stack/Setup.hs

@@ -260,7 +260,6 @@ setupEnv mResolveMissingGHC = do
         bcPath = set envOverrideL (const (return menv)) bc
 
     ls <- runRIO bcPath $ loadSnapshot
-      menv
       (Just compilerVer)
       (view projectRootL bc)
       (bcSnapshotDef bc)

src/Stack/Snapshot.hs

@@ -63,7 +63,6 @@ import           Stack.Types.Urls
 import           Stack.Types.Compiler
 import           Stack.Types.Resolver
 import qualified System.Directory as Dir
-import           System.Process.Read (EnvOverride)
 
 type SinglePackageLocation = PackageLocationIndex FilePath
 
@@ -343,24 +342,22 @@ loadResolver (ResolverCustom url loc) = do
 loadSnapshot
   :: forall env.
      (HasConfig env, HasGHCVariant env)
-  => EnvOverride -- ^ used for running Git/Hg, and if relevant, getting global package info
-  -> Maybe (CompilerVersion 'CVActual) -- ^ installed GHC we should query; if none provided, use the global hints
+  => Maybe (CompilerVersion 'CVActual) -- ^ installed GHC we should query; if none provided, use the global hints
   -> Path Abs Dir -- ^ project root, used for checking out necessary files
   -> SnapshotDef
   -> RIO env LoadedSnapshot
-loadSnapshot menv mcompiler root sd = withCabalLoader $ \loader -> loadSnapshot' loader menv mcompiler root sd
+loadSnapshot mcompiler root sd = withCabalLoader $ \loader -> loadSnapshot' loader mcompiler root sd
 
 -- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot'
 loadSnapshot'
   :: forall env.
      (HasConfig env, HasGHCVariant env)
   => (PackageIdentifierRevision -> IO ByteString) -- ^ load a cabal file's contents from the index
-  -> EnvOverride -- ^ used for running Git/Hg, and if relevant, getting global package info
   -> Maybe (CompilerVersion 'CVActual) -- ^ installed GHC we should query; if none provided, use the global hints
   -> Path Abs Dir -- ^ project root, used for checking out necessary files
   -> SnapshotDef
   -> RIO env LoadedSnapshot
-loadSnapshot' loadFromIndex menv mcompiler root =
+loadSnapshot' loadFromIndex mcompiler root =
     start
   where
     start (snapshotDefFixes -> sd) = do
@@ -384,7 +381,7 @@ loadSnapshot' loadFromIndex menv mcompiler root =
           Right sd' -> start sd'
 
       gpds <- (concat <$> mapM
-        (loadMultiRawCabalFilesIndex loadFromIndex menv root >=> mapM parseGPD)
+        (loadMultiRawCabalFilesIndex loadFromIndex root >=> mapM parseGPD)
         (sdLocations sd)) `onException` do
           logError "Unable to load cabal files for snapshot"
           case sdResolver sd of
@@ -406,7 +403,7 @@ loadSnapshot' loadFromIndex menv mcompiler root =
             _ -> return ()
 
       (globals, snapshot, locals) <-
-        calculatePackagePromotion loadFromIndex menv root ls0
+        calculatePackagePromotion loadFromIndex root ls0
         (map (\(x, y) -> (x, y, ())) gpds)
         (sdFlags sd) (sdHidden sd) (sdGhcOptions sd) (sdDropPackages sd)
 
@@ -428,7 +425,6 @@ calculatePackagePromotion
   :: forall env localLocation.
      (HasConfig env, HasGHCVariant env)
   => (PackageIdentifierRevision -> IO ByteString) -- ^ load from index
-  -> EnvOverride
   -> Path Abs Dir -- ^ project root
   -> LoadedSnapshot
   -> [(GenericPackageDescription, SinglePackageLocation, localLocation)] -- ^ packages we want to add on top of this snapshot
@@ -442,7 +438,7 @@ calculatePackagePromotion
        , Map PackageName (LoadedPackageInfo (SinglePackageLocation, Maybe localLocation)) -- new locals
        )
 calculatePackagePromotion
-  loadFromIndex menv root (LoadedSnapshot compilerVersion globals0 parentPackages0)
+  loadFromIndex root (LoadedSnapshot compilerVersion globals0 parentPackages0)
   gpds flags0 hides0 options0 drops0 = do
 
       platform <- view platformL
@@ -504,7 +500,7 @@ calculatePackagePromotion
 
       -- ... so recalculate based on new values
       upgraded <- fmap Map.fromList
-                $ mapM (recalculate loadFromIndex menv root compilerVersion flags hide ghcOptions)
+                $ mapM (recalculate loadFromIndex root compilerVersion flags hide ghcOptions)
                 $ Map.toList allToUpgrade
 
       -- Could be nice to check snapshot early... but disabling
@@ -531,22 +527,21 @@ calculatePackagePromotion
 recalculate :: forall env.
                (HasConfig env, HasGHCVariant env)
             => (PackageIdentifierRevision -> IO ByteString)
-            -> EnvOverride
             -> Path Abs Dir -- ^ root
             -> CompilerVersion 'CVActual
             -> Map PackageName (Map FlagName Bool)
             -> Map PackageName Bool -- ^ hide?
             -> Map PackageName [Text] -- ^ GHC options
             -> (PackageName, LoadedPackageInfo SinglePackageLocation)
             -> RIO env (PackageName, LoadedPackageInfo SinglePackageLocation)
-recalculate loadFromIndex menv root compilerVersion allFlags allHide allOptions (name, lpi0) = do
+recalculate loadFromIndex root compilerVersion allFlags allHide allOptions (name, lpi0) = do
   let hide = fromMaybe (lpiHide lpi0) (Map.lookup name allHide)
       options = fromMaybe (lpiGhcOptions lpi0) (Map.lookup name allOptions)
   case Map.lookup name allFlags of
     Nothing -> return (name, lpi0 { lpiHide = hide, lpiGhcOptions = options }) -- optimization
     Just flags -> do
       let loc = lpiLocation lpi0
-      gpd <- loadSingleRawCabalFile loadFromIndex menv root loc >>= parseGPDSingle loc
+      gpd <- loadSingleRawCabalFile loadFromIndex root loc >>= parseGPDSingle loc
       platform <- view platformL
       let res@(name', lpi) = calculate gpd platform compilerVersion loc flags hide options
       unless (name == name' && lpiVersion lpi0 == lpiVersion lpi) $ error "recalculate invariant violated"