Fix #6915 config set recreates global-project directory, when required

ChangeLog.md

@@ -55,6 +55,9 @@ Bug fixes:
   depends on project package B and package B's executables (only) depend on
   package A and the name of A is before that of B, alphabetically. That bug is
   fixed.
+* Stack's `config set` commands will recreate the `global-project` directory
+  contents, if Stack needs to consult its project-level configuration file and
+  there is no file.
 
 ## v3.9.3 - 2026-02-19
 

package.yaml

@@ -304,6 +304,7 @@ library:
   - Stack.Types.Component
   - Stack.Types.ComponentUtils
   - Stack.Types.Config
+  - Stack.Types.ConfigExtra
   - Stack.Types.Config.Exception
   - Stack.Types.ConfigMonoid
   - Stack.Types.ConfigSetOpts

src/Stack/Config.hs

@@ -33,6 +33,7 @@ module Stack.Config
   , defaultConfigYaml
   , getProjectConfig
   , withBuildConfig
+  , withConfigExtra
   , withNewLogFunc
   , determineStackRootAndOwnership
   ) where
@@ -126,6 +127,7 @@ import           Stack.Types.Config.Exception
                    ( ConfigException (..), ConfigPrettyException (..)
                    , ParseAbsolutePathException (..)
                    )
+import           Stack.Types.ConfigExtra ( ConfigExtra (..) )
 import           Stack.Types.ConfigMonoid
                    ( ConfigMonoid (..), parseConfigMonoid )
 import           Stack.Types.Casa ( CasaOptsMonoid (..) )
@@ -786,32 +788,77 @@ loadConfig inner = do
 -- by @loadConfig@. values.
 withBuildConfig :: RIO BuildConfig a -> RIO Config a
 withBuildConfig inner = do
-  config <- ask
+  withConfigExtra True $ \configExtra -> do
+    -- The mcompiler is provided on the command line.
+    mcompiler <- view $ globalOptsL . to (.compiler)
+    let config = configExtra.config
+        project' = configExtra.project
+        configFile = configExtra.configFile
+        project :: Project
+        project = project'
+          { Project.compiler = mcompiler <|> project'.compiler
+          , Project.snapshot = fromMaybe project'.snapshot configExtra.mSnapshot
+          }
+        -- We are indifferent as to whether the configuration file is a
+        -- user-specific global or a project-level one.
+        eitherConfigFile = EE.fromEither configFile
+    extraPackageDBs <- mapM resolveDir' project.extraPackageDBs
+
+    smWanted <- lockCachedWanted eitherConfigFile project.snapshot $
+      fillProjectWanted eitherConfigFile config project
+
+    -- Unfortunately redoes getWorkDir, since we don't have a BuildConfig yet
+    workDir <- view workDirL
+    let projectStorageFile =
+          parent eitherConfigFile </> workDir </> relFileStorage
+
+    initProjectStorage projectStorageFile $ \projectStorage -> do
+      let bc = BuildConfig
+            { config
+            , smWanted
+            , extraPackageDBs
+            , configFile
+            , curator = project.curator
+            , projectStorage
+            }
+      runRIO bc inner
 
+-- | Adds certain build-specific values to the configuration loaded by
+-- @loadConfig@ values.
+withConfigExtra ::
+     forall a env. (HasConfig env, HasTerm env)
+  => Bool
+     -- ^ Report user message in the project-level configuration file, if
+     -- a user message is present?
+  -> (ConfigExtra -> RIO env a)
+  -> RIO env a
+withConfigExtra reportUserMessage inner = do
+  config <- view configL
   -- If provided, turn the AbstractSnapshot from the command line into a
-  -- snapshot that can be used below.
+  -- snapshot that can be used.
 
-  -- The snapshot and mcompiler are provided on the command line. In order
-  -- to properly deal with an AbstractSnapshot, we need a base directory (to
-  -- deal with custom snapshot relative paths). We consider the current working
-  -- directory to be the correct base. Let's calculate the mSnapshot first.
+  -- The snapshot is provided on the command line. In order to properly deal
+  -- with an AbstractSnapshot, we need a base directory (to deal with custom
+  -- snapshot relative paths). We consider the current working directory to be
+  -- the correct base. We calculate the mSnapshot first.
   mSnapshot <- forM config.snapshot $ \aSnapshot -> do
     logDebug $
-          "Using snapshot: "
-       <> display aSnapshot
-       <> " specified on command line"
+         "Using snapshot: "
+      <> display aSnapshot
+      <> " specified on command line"
     makeConcreteSnapshot aSnapshot
 
-  (project', configFile) <- case config.project of
+  (project, configFile) <- case config.project of
     PCProject (project, fp) -> do
-      forM_ project.userMsg prettyUserMessage
+      when reportUserMessage $
+        forM_ project.userMsg prettyUserMessage
       pure (project, Right fp)
     PCNoProject extraDeps -> do
-      p <-
+      project <-
         case mSnapshot of
           Nothing -> throwIO NoSnapshotWhenUsingNoProject
           Just _ -> getEmptyProject mSnapshot extraDeps
-      pure (p, Left config.userGlobalConfigFile)
+      pure (project, Left config.userGlobalConfigFile)
     PCGlobalProject -> do
       logDebug "Run from outside a project, using implicit global project config"
       destDir <- getImplicitGlobalProjectDir
@@ -844,7 +891,7 @@ withBuildConfig inner = do
             , style Shell "snapshot"
             , flow "key there."
             ]
-          p <- getEmptyProject mSnapshot []
+          project <- getEmptyProject mSnapshot []
           liftIO $ do
             writeBinaryFileAtomic dest $ byteString $ S.concat
               [ "# This is the implicit global project's configuration file, which is only used\n"
@@ -855,45 +902,24 @@ withBuildConfig inner = do
               , "# For more information about Stack's configuration, see\n"
               , "# http://docs.haskellstack.org/en/stable/configure/yaml/\n"
               , "#\n"
-              , Yaml.encode p]
-            writeBinaryFileAtomic (parent dest </> relFileReadmeTxt) $
-              "This is the implicit global project, which is " <>
-              "used only when 'stack' is run\noutside of a " <>
-              "real project.\n"
-          pure (p, Right dest)
-  mcompiler <- view $ globalOptsL . to (.compiler)
-  let project :: Project
-      project = project'
-        { Project.compiler = mcompiler <|> project'.compiler
-        , Project.snapshot = fromMaybe project'.snapshot mSnapshot
-        }
-      -- We are indifferent as to whether the configuration file is a
-      -- user-specific global or a project-level one.
-      eitherConfigFile = EE.fromEither configFile
-  extraPackageDBs <- mapM resolveDir' project.extraPackageDBs
-
-  smWanted <- lockCachedWanted eitherConfigFile project.snapshot $
-    fillProjectWanted eitherConfigFile config project
-
-  -- Unfortunately redoes getWorkDir, since we don't have a BuildConfig yet
-  workDir <- view workDirL
-  let projectStorageFile = parent eitherConfigFile </> workDir </> relFileStorage
-
-  initProjectStorage projectStorageFile $ \projectStorage -> do
-    let bc = BuildConfig
-          { config
-          , smWanted
-          , extraPackageDBs
-          , configFile
-          , curator = project.curator
-          , projectStorage
-          }
-    runRIO bc inner
+              , Yaml.encode project
+              ]
+            writeBinaryFileAtomic (parent dest </> relFileReadmeTxt) $ mconcat
+              [ "This is the implicit global project, which is used only when 'stack' is run\n"
+              , "outside of a real project.\n"
+              ]
+          pure (project, Right dest)
+  inner $ ConfigExtra
+    { config
+    , mSnapshot
+    , project
+    , configFile
+    }
  where
   getEmptyProject ::
        Maybe RawSnapshotLocation
     -> [RawPackageLocationImmutable]
-    -> RIO Config Project
+    -> RIO env Project
   getEmptyProject mSnapshot extraDeps = do
     snapshot <- case mSnapshot of
       Just snapshot -> do
@@ -921,7 +947,7 @@ withBuildConfig inner = do
       , curator = Nothing
       , dropPackages = mempty
       }
-  prettyUserMessage :: String -> RIO Config ()
+  prettyUserMessage :: String -> RIO env ()
   prettyUserMessage userMsg = do
     let userMsgs = map flow $ splitAtLineEnds userMsg
         warningDoc = mconcat $ intersperse blankLine userMsgs

src/Stack/ConfigCmd.hs

@@ -32,22 +32,18 @@ import qualified Data.Map.Merge.Strict as Map
 import qualified Data.Text as T
 import qualified Data.Yaml as Yaml
 import           Pantry ( loadSnapshot )
-import           Path ( (</>), parent )
+import           Path ( parent )
 import qualified RIO.Map as Map
 import           RIO.NonEmpty ( nonEmpty )
 import qualified RIO.NonEmpty as NE
 import           RIO.Process ( envVarsL )
-import           Stack.Config
-                   ( makeConcreteSnapshot, getProjectConfig
-                   , getImplicitGlobalProjectDir
-                   )
-import           Stack.Constants ( stackDotYaml )
+import           Stack.Config ( makeConcreteSnapshot, withConfigExtra )
 import           Stack.Prelude
 import           Stack.Types.BuildConfig ( BuildConfig )
 import           Stack.Types.Config ( Config (..), HasConfig (..) )
+import           Stack.Types.ConfigExtra ( ConfigExtra (..) )
 import           Stack.Types.ConfigMonoid
-                   ( configMonoidInstallGHCName
-                   , configMonoidInstallMsysName
+                   ( configMonoidInstallGHCName, configMonoidInstallMsysName
                    , configMonoidRecommendStackUpgradeName
                    , configMonoidSystemGHCName
                    )
@@ -56,9 +52,6 @@ import           Stack.Types.ConfigSetOpts
 import           Stack.Types.EnvConfig ( EnvConfig )
 import           Stack.Types.EnvSettings ( EnvSettings (..) )
 import           Stack.Types.GHCVariant ( HasGHCVariant )
-import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
-import           Stack.Types.ProjectConfig ( ProjectConfig (..) )
-import           Stack.Types.Runner ( globalOptsL )
 import           Stack.Types.Snapshot ( AbstractSnapshot )
 import           System.Environment ( getEnvironment )
 
@@ -95,18 +88,14 @@ instance Exception ConfigCmdPrettyException
 cfgCmdSet ::
      (HasConfig env, HasGHCVariant env)
   => ConfigCmdSet -> RIO env ()
-cfgCmdSet cmd = do
-  conf <- view configL
-  configFilePath <-
-    case configCmdSetScope cmd of
-      CommandScopeProject -> do
-        mstackYamlOption <- view $ globalOptsL . to (.stackYaml)
-        mstackYaml <- getProjectConfig mstackYamlOption
-        case mstackYaml of
-          PCProject stackYaml -> pure stackYaml
-          PCGlobalProject -> getImplicitGlobalProjectDir <&> (</> stackDotYaml)
-          PCNoProject _extraDeps -> prettyThrowIO NoProjectConfigAvailable
-          -- maybe modify the ~/.stack/config.yaml file instead?
+-- We ignore any user message in the project-level configuration file:
+cfgCmdSet cmd = withConfigExtra False $ \configExtra -> do
+  let conf = configExtra.config
+  configFilePath <- case configCmdSetScope cmd of
+      CommandScopeProject -> case configExtra.configFile of
+        Left _ -> prettyThrowIO NoProjectConfigAvailable
+        -- Maybe modify the global configuration file (config.yaml) instead?
+        Right fp -> pure fp
       CommandScopeGlobal -> pure conf.userGlobalConfigFile
   rawConfig <- liftIO (readFileUtf8 (toFilePath configFilePath))
   config <- either throwM pure (Yaml.decodeEither' $ encodeUtf8 rawConfig)

src/Stack/Types/ConfigExtra.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+{-|
+Module      : Stack.Types.ConfigExtra
+License     : BSD-3-Clause
+-}
+
+module Stack.Types.ConfigExtra
+  ( ConfigExtra (..)
+  ) where
+
+import           Stack.Prelude
+import           Stack.Types.Config ( Config )
+import           Stack.Types.Project ( Project (..) )
+
+-- | A type that represents 'Config' values together with some extra information
+--
+data ConfigExtra = ConfigExtra
+  { config :: !Config
+  , mSnapshot :: !(Maybe RawSnapshotLocation)
+  , project :: !Project
+  , configFile :: !(Either (Path Abs File) (Path Abs File))
+    -- ^ Either (Left) the location of the user-specific global configuration
+    -- file or, in most cases, (Right) the location of the project-level
+    -- coniguration file (stack.yaml, by default).
+    --
+    -- Note: if the STACK_YAML environment variable is used, the location of the
+    -- project-level configuration file may be different from
+    -- projectRootL </> "stack.yaml" if a different file name is used.
+  }

src/Stack/Types/ProjectConfig.hs

@@ -24,7 +24,7 @@ data ProjectConfig a
     -- Instead, use the implicit global.
   | PCNoProject ![RawPackageLocationImmutable]
     -- ^ Use a no project run. This comes from
-    -- 'Stack.Types.StackYamlLocSYLNoProject'.
+    -- 'Stack.Types.StackYamlLoc.SYLNoProject'.
 
 -- | Yields 'True' only if the project configuration information is for the
 -- implicit global project.

tests/integration/tests/3770-no-rerun-tests/Main.hs

@@ -2,9 +2,9 @@
 --
 -- See: https://github.com/commercialhaskell/stack/pull/3770
 
-import          Control.Monad ( unless )
-import          Data.List ( isInfixOf )
-import          StackTest
+import           Control.Monad ( unless )
+import           Data.List ( isInfixOf )
+import           StackTest
 
 main :: IO ()
 main = do