Add progName, mExecutablePath to GlobalOpts

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude   #-}
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE TypeFamilies        #-}
@@ -66,8 +67,8 @@ 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.Config.Exception ( ConfigPrettyException (..) )
 import           Stack.Types.ConfigureOpts
                    ( BaseConfigOpts (..) )
 import           Stack.Types.DumpPackage ( DumpPackage (..) )
@@ -87,10 +88,10 @@ 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, mExecutablePathL, progNameL, terminalL )
 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 +283,10 @@ copyExecutables exes = do
           Platform _ Windows -> ".exe"
           _ -> ""
 
-  currExe <- liftIO getExecutablePath -- needed for windows, see below
+  -- needed for windows, see below
+  currExe <- view mExecutablePathL >>= \case
+    Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath
+    Just currExe -> pure $ toFilePath currExe
 
   installed <- forMaybeM (Map.toList exes) $ \(name, loc) -> do
     let strName = unqualCompToString name

src/Stack/Docker.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NoFieldSelectors    #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings   #-}
@@ -69,6 +70,7 @@ import           Stack.Storage.User
 import           Stack.Types.Config
                    ( Config (..), HasConfig (..), configProjectRoot, stackRootL
                    )
+import           Stack.Types.Config.Exception ( ConfigPrettyException (..) )
 import           Stack.Types.Docker
                   ( DockerException (..), DockerOpts (..), DockerStackExe (..)
                   , Mount (..), dockerCmdName, dockerContainerPlatform
@@ -77,12 +79,13 @@ import           Stack.Types.Docker
                   )
 import           Stack.Types.DockerEntrypoint
                    ( DockerEntrypoint (..), DockerUser (..) )
-import           Stack.Types.Runner ( HasDockerEntrypointMVar (..), terminalL )
+import           Stack.Types.Runner
+                   ( HasDockerEntrypointMVar (..), mExecutablePathL, progNameL
+                   , terminalL
+                   )
 import           Stack.Types.Version ( showStackVersion, withinRange )
 import           System.Environment
-                   ( getArgs, getEnv, getEnvironment, getExecutablePath
-                   , getProgName
-                   )
+                   ( getArgs, getEnv, getEnvironment, getProgName )
 import qualified System.FilePath as FP
 import           System.IO.Error ( isDoesNotExistError )
 import qualified System.Posix.User as User
@@ -126,18 +129,23 @@ getCmdArgs docker imageInfo isRemoteDocker = do
     case config.docker.stackExe of
         Just DockerStackExeHost
           | config.platform == dockerContainerPlatform -> do
-              exePath <- resolveFile' =<< liftIO getExecutablePath
+              exePath <- view mExecutablePathL >>= \case
+                Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath
+                Just executablePath -> pure executablePath
               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 <- view mExecutablePathL >>= \case
+                       Nothing ->
+                         view progNameL >>= prettyThrowM . NoExecutablePath
+                       Just executablePath -> pure executablePath
                      exeTimestamp <- getModificationTime exePath
                      isKnown <-
                          loadDockerImageExeCache

src/Stack/Nix.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude   #-}
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings   #-}
 
@@ -23,10 +24,12 @@ import           Stack.Prelude
 import           Stack.Types.BuildConfig ( wantedCompilerVersionL )
 import           Stack.Types.Config
                    ( Config (..), HasConfig (..), configProjectRoot )
+import           Stack.Types.Config.Exception ( ConfigPrettyException (..) )
 import           Stack.Types.Docker ( reExecArgName )
+import           Stack.Types.Runner ( mExecutablePathL, progNameL )
 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 +52,9 @@ runShellAndExit = do
              -- first stack when restarting in the container
            | otherwise =
                ("--" ++ reExecArgName ++ "=" ++ showStackVersion) : origArgs
-  exePath <- liftIO getExecutablePath
+  exePath <- view mExecutablePathL >>= \case
+    Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath
+    Just executablePath -> pure $ toFilePath executablePath
   config <- view configL
   envOverride <- view processContextL
   local (set processContextL envOverride) $ do

src/Stack/Options/Completion.hs

@@ -57,7 +57,7 @@ buildConfigCompleter inner = mkCompleter $ \inputRaw -> do
     -- If it looks like a flag, skip this more costly completion.
     ('-': _) -> pure []
     _ -> do
-      go' <- globalOptsFromMonoid False mempty
+      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/Setup.hs

@@ -143,6 +143,7 @@ import           Stack.Types.Config
                    ( Config (..), HasConfig (..), envOverrideSettingsL
                    , ghcInstallHook
                    )
+import           Stack.Types.Config.Exception ( ConfigPrettyException (..) )
 import           Stack.Types.DownloadInfo ( DownloadInfo (..) )
 import           Stack.Types.DumpPackage ( DumpPackage (..) )
 import           Stack.Types.EnvConfig
@@ -163,7 +164,8 @@ 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, progNameL )
 import           Stack.Types.SetupInfo ( SetupInfo (..) )
 import           Stack.Types.SourceMap
                    ( SMActual (..), SMWanted (..), SourceMap (..) )
@@ -173,7 +175,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 +728,9 @@ setupEnv needTargets buildOptsCLI mResolveMissingGHC = do
 
   distDir <- runReaderT distRelativeDir envConfig0 >>= canonicalizePath
 
-  executablePath <- liftIO getExecutablePath
+  executablePath <- view mExecutablePathL >>= \case
+    Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath
+    Just executablePath -> pure executablePath
 
   utf8EnvVars <- withProcessContext menv $ getUtf8EnvVars compilerVer
 
@@ -751,7 +755,8 @@ setupEnv needTargets buildOptsCLI mResolveMissingGHC = do
                    else id)
 
               $ (if es.stackExe
-                   then Map.insert "STACK_EXE" (T.pack executablePath)
+                   then
+                     Map.insert "STACK_EXE" (T.pack $ toFilePath executablePath)
                    else id)
 
               $ (if es.localeUtf8
@@ -2948,10 +2953,12 @@ 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 <- view mExecutablePathL >>= \case
+    Nothing -> view progNameL >>= prettyThrowM . NoExecutablePath
+    Just executablePath -> pure executablePath
 
   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

@@ -13,6 +13,8 @@ module Stack.Types.Runner
   , terminalL
   , reExecL
   , rslInLogL
+  , progNameL
+  , mExecutablePathL
   ) where
 
 import           RIO.Process ( HasProcessContext (..), ProcessContext )
@@ -91,3 +93,11 @@ 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)