Add progName, mExecutablePath to GlobalOpts

doc/commands/exec_command.md

@@ -19,8 +19,10 @@ By default:
 * the `GHC_PACKAGE_PATH` environment variable is set for the command's process.
   Pass the flag `--no-ghc-package-path` to not set the environment variable;
 
-* the `STACK_EXE` environment variable is set for the command's process. Pass
-  the flag `--no-stack-exe` to not set the environment variable; and
+* if the operating system provides a reliable way to determine it and where a
+  result was available, the `STACK_EXE` environment variable is set to the path
+  to the current Stack executable for the command's process. Pass the flag
+  `--no-stack-exe` to not set the environment variable; and
 
 * the specified executable is executed in the current directory. Pass the option
   `--cwd <directory>` to execute the executable in the specified directory.

doc/maintainers/stack_errors.md

@@ -5,7 +5,7 @@
 In connection with considering Stack's support of the
 [Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks
 to take stock of the errors that Stack itself can raise, by reference to the
-`master` branch of the Stack repository. Last updated: 2024-06-03.
+`master` branch of the Stack repository. Last updated: 2024-08-02.
 
 *   `Stack.main`: catches exceptions from action `commandLineHandler`.
 
@@ -424,6 +424,7 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-6854] | BadMsysEnvironment MsysEnvironment Arch
         [S-5006] | NoDefaultMsysEnvironmentBug
         [S-8398] | ConfigFileNotProjectLevelBug
+        [S-6890] | NoExecutablePath String
         ~~~
 
     -   `Stack.Types.Config.ParseAbsolutePathException`

src/Stack.hs

@@ -82,7 +82,8 @@ main = do
     Left (exitCode :: ExitCode) ->
       throwIO exitCode
     Right (globalMonoid, run) -> do
-      global <- globalOptsFromMonoid isTerminal globalMonoid
+      global <-
+        globalOptsFromMonoid progName mExecutablePath isTerminal globalMonoid
       when (global.logLevel == LevelDebug) $
         hPutStrLn stderr versionString'
       whenJust global.reExecVersion $ \expectVersion -> do

src/Stack/Build/Execute.hs

@@ -66,8 +66,7 @@ import           Stack.Types.Compiler ( ActualCompiler (..) )
 import           Stack.Types.CompilerPaths ( HasCompiler (..), getGhcPkgExe )
 import           Stack.Types.ComponentUtils
                    ( StackUnqualCompName, unqualCompToString )
-import           Stack.Types.Config
-                   ( Config (..), HasConfig (..), buildOptsL )
+import           Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
 import           Stack.Types.ConfigureOpts
                    ( BaseConfigOpts (..) )
 import           Stack.Types.DumpPackage ( DumpPackage (..) )
@@ -87,10 +86,9 @@ import           Stack.Types.NamedComponent
 import           Stack.Types.Package
                    ( LocalPackage (..), Package (..), packageIdentifier )
 import           Stack.Types.Platform ( HasPlatform (..) )
-import           Stack.Types.Runner ( HasRunner, terminalL )
+import           Stack.Types.Runner ( HasRunner, terminalL, viewExecutablePath )
 import           Stack.Types.SourceMap ( Target )
 import qualified System.Directory as D
-import           System.Environment ( getExecutablePath )
 import qualified System.FilePath as FP
 
 -- | Fetch the packages necessary for a build, for example in combination with
@@ -282,7 +280,8 @@ copyExecutables exes = do
           Platform _ Windows -> ".exe"
           _ -> ""
 
-  currExe <- liftIO getExecutablePath -- needed for windows, see below
+  -- needed for windows, see below
+  currExe <- toFilePath <$> viewExecutablePath
 
   installed <- forMaybeM (Map.toList exes) $ \(name, loc) -> do
     let strName = unqualCompToString name

src/Stack/Docker.hs

@@ -44,7 +44,7 @@ import           Path.Extra ( toFilePathNoTrailingSep )
 import           Path.IO
                    ( copyFile, doesDirExist, doesFileExist, ensureDir
                    , getCurrentDir, getHomeDir, getModificationTime, listDir
-                   , removeDirRecur, removeFile, resolveFile'
+                   , removeDirRecur, removeFile
                    )
 import qualified RIO.Directory ( makeAbsolute )
 import           RIO.Process
@@ -77,12 +77,12 @@ import           Stack.Types.Docker
                   )
 import           Stack.Types.DockerEntrypoint
                    ( DockerEntrypoint (..), DockerUser (..) )
-import           Stack.Types.Runner ( HasDockerEntrypointMVar (..), terminalL )
-import           Stack.Types.Version ( showStackVersion, withinRange )
-import           System.Environment
-                   ( getArgs, getEnv, getEnvironment, getExecutablePath
-                   , getProgName
+import           Stack.Types.Runner
+                   ( HasDockerEntrypointMVar (..), progNameL, terminalL
+                   , viewExecutablePath
                    )
+import           Stack.Types.Version ( showStackVersion, withinRange )
+import           System.Environment ( getArgs, getEnv, getEnvironment )
 import qualified System.FilePath as FP
 import           System.IO.Error ( isDoesNotExistError )
 import qualified System.Posix.User as User
@@ -126,18 +126,18 @@ getCmdArgs docker imageInfo isRemoteDocker = do
     case config.docker.stackExe of
         Just DockerStackExeHost
           | config.platform == dockerContainerPlatform -> do
-              exePath <- resolveFile' =<< liftIO getExecutablePath
+              exePath <- viewExecutablePath
               cmdArgs args exePath
           | otherwise -> throwIO UnsupportedStackExeHostPlatformException
         Just DockerStackExeImage -> do
-            progName <- liftIO getProgName
+            progName <- view progNameL
             pure (FP.takeBaseName progName, args, [], [])
         Just (DockerStackExePath path) -> cmdArgs args path
         Just DockerStackExeDownload -> exeDownload args
         Nothing
           | config.platform == dockerContainerPlatform -> do
               (exePath, exeTimestamp, misCompatible) <-
-                  do exePath <- resolveFile' =<< liftIO getExecutablePath
+                  do exePath <- viewExecutablePath
                      exeTimestamp <- getModificationTime exePath
                      isKnown <-
                          loadDockerImageExeCache

src/Stack/Nix.hs

@@ -24,9 +24,10 @@ import           Stack.Types.BuildConfig ( wantedCompilerVersionL )
 import           Stack.Types.Config
                    ( Config (..), HasConfig (..), configProjectRoot )
 import           Stack.Types.Docker ( reExecArgName )
+import           Stack.Types.Runner ( viewExecutablePath )
 import           Stack.Types.Nix ( NixOpts (..) )
 import           Stack.Types.Version ( showStackVersion )
-import           System.Environment ( getArgs, getExecutablePath, lookupEnv )
+import           System.Environment ( getArgs, lookupEnv )
 import qualified System.FilePath as F
 
 -- | Type representing exceptions thrown by functions exported by the
@@ -49,7 +50,7 @@ runShellAndExit = do
              -- first stack when restarting in the container
            | otherwise =
                ("--" ++ reExecArgName ++ "=" ++ showStackVersion) : origArgs
-  exePath <- liftIO getExecutablePath
+  exePath <- toFilePath <$> viewExecutablePath
   config <- view configL
   envOverride <- view processContextL
   local (set processContextL envOverride) $ do

src/Stack/Options/Completion.hs

@@ -48,16 +48,17 @@ ghcOptsCompleter = mkCompleter $ \inputRaw -> pure $
 -- TODO: Ideally this would pay attention to --stack-yaml, may require
 -- changes to optparse-applicative.
 
-buildConfigCompleter ::
-     (String -> RIO EnvConfig [String])
-  -> Completer
+buildConfigCompleter :: (String -> RIO EnvConfig [String]) -> Completer
 buildConfigCompleter inner = mkCompleter $ \inputRaw -> do
   let input = unescapeBashArg inputRaw
   case input of
     -- If it looks like a flag, skip this more costly completion.
     ('-': _) -> pure []
     _ -> do
-      go' <- globalOptsFromMonoid False mempty
+      -- We do not need to specify the name of the current Stack executable, as
+      -- it was invoked, or the path to the current Stack executable, as
+      -- withDefaultEnvConfig does not need either.
+      go' <- globalOptsFromMonoid "" Nothing False mempty
       let go = go' { logLevel = LevelOther "silent" }
       withRunnerGlobal go $ withConfig NoReexec $ withDefaultEnvConfig $ inner input
 

src/Stack/Options/GlobalParser.hs

@@ -114,10 +114,16 @@ globalOptsParser currentDir kind = GlobalOptsMonoid
 -- | Create GlobalOpts from GlobalOptsMonoid.
 globalOptsFromMonoid ::
      MonadIO m
-  => Bool
+  => String
+     -- ^ The name of the current Stack executable, as it was invoked.
+  -> Maybe (Path Abs File)
+     -- ^ The path to the current Stack executable, if the operating system
+     -- provides a reliable way to determine it and where a result was
+     -- available.
+  -> Bool
   -> GlobalOptsMonoid
   -> m GlobalOpts
-globalOptsFromMonoid defaultTerminal globalMonoid = do
+globalOptsFromMonoid progName mExecutablePath defaultTerminal globalMonoid = do
   snapshot <- for (getFirst globalMonoid.snapshot) $ \us -> do
     root <-
       case globalMonoid.snapshotRoot of
@@ -149,6 +155,8 @@ globalOptsFromMonoid defaultTerminal globalMonoid = do
     , termWidthOpt = getFirst globalMonoid.termWidthOpt
     , stackYaml
     , lockFileBehavior
+    , progName
+    , mExecutablePath
     }
 
 -- | Default logging level should be something useful but not crazy.

src/Stack/Options/LsParser.hs

@@ -160,8 +160,7 @@ formatSubCommand ::
   -> OA.Mod OA.CommandFields ListDepsOpts
 formatSubCommand cmd desc formatParser =
   OA.command
-    cmd
-    (OA.info (toListDepsOptsParser formatParser) (OA.progDesc desc))
+    cmd (OA.info (toListDepsOptsParser formatParser) (OA.progDesc desc))
 
 listDepsTextParser :: OA.Parser ListDepsFormat
 listDepsTextParser =

src/Stack/Setup.hs

@@ -163,7 +163,10 @@ import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
 import           Stack.Types.Platform
                    ( HasPlatform (..), PlatformVariant (..)
                    , platformOnlyRelDir )
-import           Stack.Types.Runner ( HasRunner (..), Runner (..) )
+import           Stack.Types.Runner
+                   ( HasRunner (..), Runner (..), mExecutablePathL
+                   , viewExecutablePath
+                   )
 import           Stack.Types.SetupInfo ( SetupInfo (..) )
 import           Stack.Types.SourceMap
                    ( SMActual (..), SMWanted (..), SourceMap (..) )
@@ -173,7 +176,7 @@ import           Stack.Types.VersionedDownloadInfo
                    ( VersionedDownloadInfo (..) )
 import           Stack.Types.WantedCompilerSetter ( WantedCompilerSetter (..) )
 import qualified System.Directory as D
-import           System.Environment ( getExecutablePath, lookupEnv )
+import           System.Environment ( lookupEnv )
 import           System.IO.Error ( isPermissionError )
 import           System.FilePath ( searchPathSeparator )
 import qualified System.FilePath as FP
@@ -726,7 +729,7 @@ setupEnv needTargets buildOptsCLI mResolveMissingGHC = do
 
   distDir <- runReaderT distRelativeDir envConfig0 >>= canonicalizePath
 
-  executablePath <- liftIO getExecutablePath
+  mExecutablePath <- view mExecutablePathL
 
   utf8EnvVars <- withProcessContext menv $ getUtf8EnvVars compilerVer
 
@@ -751,7 +754,16 @@ setupEnv needTargets buildOptsCLI mResolveMissingGHC = do
                    else id)
 
               $ (if es.stackExe
-                   then Map.insert "STACK_EXE" (T.pack executablePath)
+                   then maybe
+                     -- We don't throw an exception if there is no Stack
+                     -- executable path, so that buildConfigCompleter does not
+                     -- need to specify a path.
+                     id
+                     ( \executablePath -> Map.insert
+                         "STACK_EXE"
+                         (T.pack $ toFilePath executablePath)
+                     )
+                     mExecutablePath
                    else id)
 
               $ (if es.localeUtf8
@@ -2948,10 +2960,10 @@ downloadStackExe platforms0 archiveInfo destDir checkPath testExe = do
 
   prettyInfoS "Download complete, testing executable."
 
-  -- We need to call getExecutablePath before we overwrite the
-  -- currently running binary: after that, Linux will append
-  -- (deleted) to the filename.
-  currExe <- liftIO getExecutablePath >>= parseAbsFile
+  -- We need to preserve the name of the executable file before we overwrite the
+  -- currently running binary: after that, Linux will append (deleted) to the
+  -- filename.
+  currExe <- viewExecutablePath
 
   liftIO $ do
     setFileExecutable (toFilePath tmpFile)

src/Stack/Types/Config/Exception.hs

@@ -168,6 +168,7 @@ data ConfigPrettyException
   | BadMsysEnvironment !MsysEnvironment !Arch
   | NoMsysEnvironmentBug
   | ConfigFileNotProjectLevelBug
+  | NoExecutablePath !String
   deriving (Show, Typeable)
 
 instance Pretty ConfigPrettyException where
@@ -238,6 +239,14 @@ instance Pretty ConfigPrettyException where
     flow "No default MSYS2 environment."
   pretty ConfigFileNotProjectLevelBug = bugPrettyReport "[S-8398]" $
     flow "The configuration file is not a project-level one."
+  pretty (NoExecutablePath progName) =
+    "[S-6890]"
+    <> line
+    <> fillSep
+         [ flow "The path for the executable file invoked as"
+         , style Shell (fromString progName)
+         , flow "can not be identified."
+         ]
 
 instance Exception ConfigPrettyException
 

src/Stack/Types/GlobalOpts.hs

@@ -17,27 +17,33 @@ import          Stack.Types.Snapshot ( AbstractSnapshot )
 
 -- | Parsed global command-line options.
 data GlobalOpts = GlobalOpts
-  { reExecVersion :: !(Maybe String)
+  { reExecVersion    :: !(Maybe String)
     -- ^ Expected re-exec in container version
   , dockerEntrypoint :: !(Maybe DockerEntrypoint)
     -- ^ Data used when Stack is acting as a Docker entrypoint (internal use
     -- only)
-  , logLevel     :: !LogLevel -- ^ Log level
-  , timeInLog    :: !Bool -- ^ Whether to include timings in logs.
-  , rslInLog     :: !Bool
+  , logLevel         :: !LogLevel -- ^ Log level
+  , timeInLog        :: !Bool -- ^ Whether to include timings in logs.
+  , rslInLog         :: !Bool
     -- ^ Whether to include raw snapshot layer (RSL) in logs.
-  , planInLog :: !Bool
+  , planInLog        :: !Bool
     -- ^ Whether to include debug information about the construction of the
     -- build plan in logs.
-  , configMonoid :: !ConfigMonoid
+  , configMonoid     :: !ConfigMonoid
     -- ^ Config monoid, for passing into 'loadConfig'
-  , snapshot     :: !(Maybe AbstractSnapshot) -- ^ Snapshot override
-  , compiler     :: !(Maybe WantedCompiler) -- ^ Compiler override
-  , terminal     :: !Bool -- ^ We're in a terminal?
-  , stylesUpdate :: !StylesUpdate -- ^ SGR (Ansi) codes for styles
-  , termWidthOpt  :: !(Maybe Int) -- ^ Terminal width override
-  , stackYaml    :: !StackYamlLoc -- ^ Override project stack.yaml
+  , snapshot         :: !(Maybe AbstractSnapshot) -- ^ Snapshot override
+  , compiler         :: !(Maybe WantedCompiler) -- ^ Compiler override
+  , terminal         :: !Bool -- ^ We're in a terminal?
+  , stylesUpdate     :: !StylesUpdate -- ^ SGR (Ansi) codes for styles
+  , termWidthOpt     :: !(Maybe Int) -- ^ Terminal width override
+  , stackYaml        :: !StackYamlLoc -- ^ Override project stack.yaml
   , lockFileBehavior :: !LockFileBehavior
+  , progName         :: !String
+    -- ^ The name of the current Stack executable, as it was invoked.
+  , mExecutablePath  :: !(Maybe (Path Abs File))
+    -- ^ The path to the current Stack executable, if the operating system
+    -- provides a reliable way to determine it and where a result was
+    -- available.
   }
 
 globalOptsBuildOptsMonoidL :: Lens' GlobalOpts BuildOptsMonoid

src/Stack/Types/Runner.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE NoFieldSelectors      #-}
 {-# LANGUAGE OverloadedRecordDot   #-}
 
@@ -13,10 +14,14 @@ module Stack.Types.Runner
   , terminalL
   , reExecL
   , rslInLogL
+  , progNameL
+  , mExecutablePathL
+  , viewExecutablePath
   ) where
 
 import           RIO.Process ( HasProcessContext (..), ProcessContext )
 import           Stack.Prelude hiding ( stylesUpdate )
+import           Stack.Types.Config.Exception ( ConfigPrettyException (..) )
 import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
 import           Stack.Types.LockFileBehavior ( LockFileBehavior )
 import           Stack.Types.StackYamlLoc ( StackYamlLoc )
@@ -91,3 +96,19 @@ reExecL = globalOptsL . to (isJust . (.reExecVersion))
 -- | See the @rslInLog@ field of the 'GlobalOpts' data constructor.
 rslInLogL :: HasRunner env => SimpleGetter env Bool
 rslInLogL = globalOptsL . to (.rslInLog)
+
+-- | See the @progNameL@ field of the 'GlobalOpts' data constructor.
+progNameL :: HasRunner env => SimpleGetter env String
+progNameL = globalOptsL . to (.progName)
+
+-- | See the @mExecutablePath@ field of the 'GlobalOpts' data constructor.
+mExecutablePathL :: HasRunner env => SimpleGetter env (Maybe (Path Abs File))
+mExecutablePathL = globalOptsL . to (.mExecutablePath)
+
+-- | Yield the path to the current Stack executable, if the operating system
+-- provides a reliable way to determine it. Otherwise throw
+-- 'Stack.Types.Config.Exception.NoExecutablePath'.
+viewExecutablePath :: HasRunner env => RIO env (Path Abs File)
+viewExecutablePath = view mExecutablePathL >>= \case
+    Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath
+    Just executablePath -> pure executablePath

tests/unit/Stack/ConfigSpec.hs

@@ -168,7 +168,7 @@ spec = beforeAll setup $ do
 
   describe "parseProjectAndConfigMonoid" $ do
     let loadProject' fp inner = do
-          globalOpts <- globalOptsFromMonoid False mempty
+          globalOpts <- globalOptsFromMonoid "" Nothing False mempty
           withRunnerGlobal globalOpts { logLevel = logLevel } $ do
               iopc <- loadConfigYaml (
                 parseProjectAndConfigMonoid (parent fp)
@@ -199,7 +199,7 @@ spec = beforeAll setup $ do
 
   describe "loadConfig" $ do
     let loadConfig' inner = do
-          globalOpts <- globalOptsFromMonoid False mempty
+          globalOpts <- globalOptsFromMonoid "" Nothing False mempty
           withRunnerGlobal globalOpts { logLevel = logLevel } $
             loadConfig inner
     -- TODO(danburton): make sure parent dirs also don't have config file