Merge branch 'issue-1106'

haskell · Jul 20, 2024 · bcb35b1 · bcb35b1
2 parents c2cf9fc + d63cf86
commit bcb35b1
Show file tree

Hide file tree

Showing 2 changed files with 28 additions and 4 deletions.
diff --git a/lib-opt/GHCup/OptParse/Run.hs b/lib-opt/GHCup/OptParse/Run.hs
@@ -20,7 +20,7 @@ import           GHCup.Prelude
 import           GHCup.Prelude.File
 #ifdef IS_WINDOWS
 import           GHCup.Prelude.Process
-import           GHCup.Prelude.Process.Windows ( execNoMinGW )
+import           GHCup.Prelude.Process.Windows ( execNoMinGW, resolveExecutable )
 #endif
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.String.QQ
@@ -32,7 +32,7 @@ import           Control.Monad.Fail             ( MonadFail )
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
 import           Data.Functor
-import           Data.Maybe (isNothing)
+import           Data.Maybe (isNothing, fromMaybe)
 import           Data.List                      ( intercalate )
 import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
@@ -268,9 +268,10 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
                pure ExitSuccess
 #else
+               resolvedCmd <- fmap (fromMaybe cmd) $ liftIO $ resolveExecutable cmd runMinGWPath
                r' <- if runMinGWPath
-                     then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
-                     else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv)
+                     then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec resolvedCmd args Nothing (Just newEnv)
+                     else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW resolvedCmd args Nothing (Just newEnv)
                case r' of
                  VRight _ -> pure ExitSuccess
                  VLeft e -> do

diff --git a/lib/GHCup/Prelude/Process/Windows.hs b/lib/GHCup/Prelude/Process/Windows.hs
@@ -32,6 +32,7 @@ import           System.Environment
 import           System.FilePath
 import           System.IO
 import           System.Process
+import           System.Win32.Info (getSystemDirectory, getWindowsDirectory)
 
 import qualified Control.Exception             as EX
 import qualified Data.ByteString               as BS
@@ -219,6 +220,28 @@ exec exe args chdir env' = do
   exit_code <- liftIO $ withRestorePath (env cp) $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
   pure $ toProcessError exe args exit_code
 
+
+-- See:
+-- - https://github.com/haskell/ghcup-hs/issues/1106
+-- - https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375#note_435793
+--
+-- We emulate the logic of 'CreateProcessW' described under the parameter
+-- 'lpApplicationName': https://learn.microsoft.com/en-us/windows/win32/api/processthreadsapi/nf-processthreadsapi-createprocessw#parameters
+-- ...while NOT considering the directory from which the application is loaded (which is C:/ghcup/bin)
+resolveExecutable :: FilePath -> Bool -> IO (Maybe FilePath)
+resolveExecutable fp minGW
+  | length (splitPath fp) /= 1 = pure $ Just fp
+  | otherwise = do
+      system32Dir <- getSystemDirectory
+      windowsDir <- getWindowsDirectory
+      curDir <- getCurrentDirectory
+      let system16Dir = windowsDir </> "System"
+      mingWPaths <- if minGW then ghcupMsys2BinDirs' else pure []
+      path  <- getSearchPath
+      let withExtension = if hasExtension fp then fp else fp <.> "exe"
+      searchPath (curDir:system32Dir:system16Dir:windowsDir:(mingWPaths ++ path)) withExtension
+
+
 -- | Like 'exec', except doesn't add msys2 stuff to PATH.
 execNoMinGW :: MonadIO m
      => FilePath       -- ^ thing to execute