[RFC] Send output of building setup to stderr (fixes #1410)

src/Stack/Build/Execute.hs

@@ -273,7 +273,7 @@ getSetupExe setupHs tmpdir = do
                     , toFilePath tmpOutputPath
                     ] ++
                     ["-build-runner" | wc == Ghcjs]
-            runIn tmpdir (compilerExeName wc) menv args Nothing
+            runCmd' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) Nothing
             when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath
             renameFile tmpExePath exePath
             return $ Just exePath
@@ -413,7 +413,7 @@ executePlan menv bopts baseConfigOpts locals globalPackages snapshotPackages loc
                     }
     forM_ (boptsExec bopts) $ \(cmd, args) -> do
         $logProcessRun cmd args
-        callProcess Nothing menv' cmd args
+        callProcess (Cmd Nothing cmd menv' args)
 
 -- | Windows can't write over the current executable. Instead, we rename the
 -- current executable to something else and then do the copy.

src/Stack/Docker.hs

@@ -349,15 +349,17 @@ runContainerAndExit getCmdArgs
        oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing
        return (sig, oldHandler)
 #endif
-     e <- try (callProcess'
-                 (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False }))
-                 Nothing
-                 envOverride
+     let cmd = Cmd Nothing
                  "docker"
+                 envOverride
                  (concat [["start"]
                          ,["-a" | not (dockerDetach docker)]
                          ,["-i" | keepStdinOpen]
-                         ,[containerID]]))
+                         ,[containerID]])
+     e <- try (callProcess'
+                 (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False }))
+                 cmd
+                 )
 #ifndef WINDOWS
      forM_ oldHandlers $ \(sig,oldHandler) ->
        liftIO $ installHandler sig oldHandler Nothing
@@ -646,16 +648,16 @@ pullImage envOverride docker image =
   do $logInfo (concatT ["Pulling image from registry: '",image,"'"])
      when (dockerRegistryLogin docker)
           (do $logInfo "You may need to log in."
-              callProcess
+              callProcess $ Cmd
                 Nothing
-                envOverride
                 "docker"
+                envOverride
                 (concat
                    [["login"]
                    ,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker)
                    ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker)
                    ,[takeWhile (/= '/') image]]))
-     e <- try (callProcess Nothing envOverride "docker" ["pull",image])
+     e <- try (callProcess (Cmd Nothing "docker" envOverride ["pull",image]))
      case e of
        Left (ProcessExitedUnsuccessfully _ _) -> throwM (PullFailedException image)
        Right () -> return ()

src/Stack/Exec.hs

@@ -20,7 +20,7 @@ import           System.Process.Read (EnvOverride)
 import           Control.Exception.Lifted
 import           Data.Streaming.Process (ProcessExitedUnsuccessfully(..))
 import           System.Exit
-import           System.Process.Run (callProcess)
+import           System.Process.Run (callProcess, Cmd(..))
 #else
 import           System.Process.Read (envHelper, preProcess)
 import           System.Posix.Process (executeFile)
@@ -50,7 +50,7 @@ exec :: (MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)
 exec menv cmd0 args = do
     $logProcessRun cmd0 args
 #ifdef WINDOWS
-    e <- try (callProcess Nothing menv cmd0 args)
+    e <- try (callProcess (Cmd Nothing cmd0 menv args))
     liftIO $ case e of
         Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec
         Right () -> exitSuccess

src/Stack/Ide.hs

@@ -73,9 +73,9 @@ ide targets useropts = do
     Platform _ os <- asks getPlatform
     when
         (os == OSX)
-        (catch (callProcess (Just pwd) menv "stty" ["cbreak", "-imaxbel"])
+        (catch (callProcess (Cmd (Just pwd) "stty" menv ["cbreak", "-imaxbel"]))
                (\(_ :: ProcessExitedUnsuccessfully) -> return ()))
-    callProcess (Just pwd) menv "stack-ide" args
+    callProcess (Cmd (Just pwd) "stack-ide" menv args)
   where
     includeDirs pkgopts =
         intercalate

src/Stack/Image.hs

@@ -113,16 +113,14 @@ createDockerImage dir = do
                           (dir </>
                            $(mkRelFile "Dockerfile")))
                      (unlines ["FROM " ++ base, "ADD ./ /"]))
-            callProcess
-                Nothing
-                menv
-                "docker"
-                [ "build"
-                , "-t"
-                , fromMaybe
-                      (imageName (parent (parent dir)))
-                      (imgDockerImageName =<< dockerConfig)
-                , toFilePathNoTrailingSep dir]
+            let args = [ "build"
+                       , "-t"
+                       , fromMaybe
+                             (imageName (parent (parent dir)))
+                             (imgDockerImageName =<< dockerConfig)
+                       , toFilePathNoTrailingSep dir]
+            callProcess $ Cmd Nothing "docker" menv args
+
 
 -- | Extend the general purpose docker image with entrypoints (if
 -- specified).
@@ -151,10 +149,10 @@ extendDockerImageWithEntrypoint dir = do
                                     , "ENTRYPOINT [\"/usr/local/bin/" ++
                                       ep ++ "\"]"
                                     , "CMD []"]))
-                      callProcess
+                      callProcess $ Cmd
                           Nothing
-                          menv
                           "docker"
+                          menv
                           [ "build"
                           , "-t"
                           , dockerImageName ++ "-" ++ ep

src/Stack/New.hs

@@ -213,7 +213,7 @@ runTemplateInits dir = do
     case configScmInit config of
         Nothing -> return ()
         Just Git ->
-            catch (callProcess (Just dir) menv "git" ["init"])
+            catch (callProcess $ Cmd (Just dir) "git" menv ["init"])
                   (\(_ :: ProcessExitedUnsuccessfully) ->
                          $logInfo "git init failed to run, ignoring ...")
 

src/Stack/Setup.hs

@@ -87,7 +87,7 @@ import           System.FilePath (searchPathSeparator)
 import qualified System.FilePath as FP
 import           System.Process (rawSystem)
 import           System.Process.Read
-import           System.Process.Run (runIn)
+import           System.Process.Run (runCmd, Cmd(..))
 import           Text.Printf (printf)
 
 -- | Default location of the stack-setup.yaml file
@@ -512,7 +512,7 @@ upgradeCabal menv wc = do
                     Nothing -> error "upgradeCabal: Invariant violated, dir missing"
                     Just dir -> return dir
 
-            runIn dir (compilerExeName wc) menv ["Setup.hs"] Nothing
+            runCmd (Cmd (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing
             platform <- asks getPlatform
             let setupExe = toFilePath $ dir </>
                   (case platform of
@@ -524,13 +524,10 @@ upgradeCabal menv wc = do
                     , "dir="
                     , installRoot FP.</> name'
                     ]
-            runIn dir setupExe menv
-                ( "configure"
-                : map dirArgument (words "lib bin data doc")
-                )
-                Nothing
-            runIn dir setupExe menv ["build"] Nothing
-            runIn dir setupExe menv ["install"] Nothing
+                args = ( "configure": map dirArgument (words "lib bin data doc") )
+            runCmd (Cmd (Just dir) setupExe menv args) Nothing
+            runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing
+            runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing
             $logInfo "New Cabal library installed"
 
 -- | Get the version of the system compiler, if available
@@ -1077,14 +1074,14 @@ installMsys2Windows osKey si archiveFile archiveType destDir = do
     -- I couldn't find this officially documented anywhere, but you need to run
     -- the shell once in order to initialize some pacman stuff. Once that run
     -- happens, you can just run commands as usual.
-    runIn destDir "sh" menv ["--login", "-c", "true"] Nothing
+    runCmd (Cmd (Just destDir) "sh" menv ["--login", "-c", "true"]) Nothing
 
     -- No longer installing git, it's unreliable
     -- (https://github.com/commercialhaskell/stack/issues/1046) and the
     -- MSYS2-installed version has bad CRLF defaults.
     --
     -- Install git. We could install other useful things in the future too.
-    -- runIn destDir "pacman" menv ["-Sy", "--noconfirm", "git"] Nothing
+    -- runCmd (Cmd (Just destDir) "pacman" menv ["-Sy", "--noconfirm", "git"]) Nothing
 
 -- | Unpack a compressed tarball using 7zip.  Expects a single directory in
 -- the unpacked results, which is renamed to the destination directory.

src/Stack/Upgrade.hs

@@ -50,18 +50,14 @@ upgrade gitRepo mresolver builtHash =
                     <> "built from is not available due to how it was built. "
                     <> "Will continue by assuming an upgrade is needed "
                     <> "because we have no information to the contrary."
-        if builtHash == Just latestCommit then do
-          $logInfo "Already up-to-date, no upgrade required"
-          return Nothing
-        else do $logInfo "Cloning stack"
-                runIn tmp "git" menv
-                    [ "clone"
-                    , repo
-                    , "stack"
-                    , "--depth"
-                    , "1"
-                    ]
-                    Nothing
+        if builtHash == Just latestCommit
+            then do
+                $logInfo "Already up-to-date, no upgrade required"
+                return Nothing
+            else do
+                $logInfo "Cloning stack"
+                let args = [ "clone", repo , "stack", "--depth", "1"]
+                runCmd (Cmd (Just tmp) "git" menv args) Nothing
                 return $ Just $ tmp </> $(mkRelDir "stack")
       Nothing -> do
         updateAllIndices menv

src/System/Process/Run.hs

@@ -5,14 +5,17 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
-
+{-# LANGUAGE RecordWildCards #-}
 -- | Run sub-processes.
 
 module System.Process.Run
-    (runIn
+    (runCmd
+    ,runCmd'
     ,callProcess
     ,callProcess'
-    ,ProcessExitedUnsuccessfully)
+    ,ProcessExitedUnsuccessfully
+    ,Cmd(..)
+    )
     where
 
 import           Control.Exception.Lifted
@@ -23,38 +26,54 @@ import           Data.Conduit.Process hiding (callProcess)
 import           Data.Foldable (forM_)
 import           Data.Text (Text)
 import qualified Data.Text as T
-import           Path (Path, Abs, Dir, toFilePath)
+import           Path (toFilePath)
 import           Prelude -- Fix AMP warning
 import           System.Exit (exitWith, ExitCode (..))
 import qualified System.Process
 import           System.Process.Read
+import           Path (Dir, Abs, Path)
+
+-- | Cmd holds common infos needed to running a process in most cases
+data Cmd = Cmd
+  { cmdDirectoryToRunIn :: Maybe (Path Abs Dir) -- ^ directory to run in
+  , cmdCommandToRun :: FilePath -- ^ command to run
+  , cmdEnvOverride::EnvOverride
+  , cmdCommandLineArguments :: [String] -- ^ command line arguments
+  }
 
 -- | Run the given command in the given directory, inheriting stdout and stderr.
 --
 -- If it exits with anything but success, prints an error
 -- and then calls 'exitWith' to exit the program.
-runIn :: forall (m :: * -> *).
+runCmd :: forall (m :: * -> *).
+         (MonadLogger m,MonadIO m,MonadBaseControl IO m)
+      => Cmd
+      -> Maybe Text  -- ^ optional additional error message
+      -> m ()
+runCmd = runCmd' id
+
+runCmd' :: forall (m :: * -> *).
          (MonadLogger m,MonadIO m,MonadBaseControl IO m)
-      => Path Abs Dir -- ^ directory to run in
-      -> FilePath -- ^ command to run
-      -> EnvOverride
-      -> [String] -- ^ command line arguments
-      -> Maybe Text -- ^ optional additional error message
+      => (CreateProcess -> CreateProcess)
+      -> Cmd
+      -> Maybe Text  -- ^ optional additional error message
       -> m ()
-runIn wd cmd menv args errMsg = do
-    result <- try (callProcess (Just wd) menv cmd args)
+runCmd' modCP cmd@(Cmd{..}) mbErrMsg = do
+    result <- try (callProcess' modCP cmd)
     case result of
         Left (ProcessExitedUnsuccessfully _ ec) -> do
             $logError $
                 T.pack $
-                concat
+                concat $
                     [ "Exit code "
                     , show ec
                     , " while running "
-                    , show (cmd : args)
-                    , " in "
-                    , toFilePath wd]
-            forM_ errMsg $logError
+                    , show (cmdCommandToRun : cmdCommandLineArguments)
+                    ] ++ (case cmdDirectoryToRunIn of
+                            Nothing -> []
+                            Just mbDir -> [" in ", toFilePath mbDir]
+                            )
+            forM_ mbErrMsg $logError
             liftIO (exitWith ec)
         Right () -> return ()
 
@@ -63,28 +82,17 @@ runIn wd cmd menv args errMsg = do
 -- process exits unsuccessfully.
 --
 -- Inherits stdout and stderr.
-callProcess :: (MonadIO m, MonadLogger m)
-            => Maybe (Path Abs Dir) -- ^ optional directory to run in
-            -> EnvOverride
-            -> String -- ^ command to run
-            -> [String] -- ^ command line arguments
-            -> m ()
-callProcess =
-    callProcess' id
+callProcess :: (MonadIO m, MonadLogger m) => Cmd -> m ()
+callProcess = callProcess' id
 
 -- | Like 'System.Process.callProcess', but takes an optional working directory and
 -- environment override, and throws 'ProcessExitedUnsuccessfully' if the
 -- process exits unsuccessfully.
 --
 -- Inherits stdout and stderr.
 callProcess' :: (MonadIO m, MonadLogger m)
-             => (CreateProcess -> CreateProcess)
-             -> Maybe (Path Abs Dir) -- ^ optional directory to run in
-             -> EnvOverride
-             -> String -- ^ command to run
-             -> [String] -- ^ command line arguments
-             -> m ()
-callProcess' modCP wd menv cmd0 args = do
+             => (CreateProcess -> CreateProcess) -> Cmd -> m ()
+callProcess' modCP (Cmd wd cmd0 menv args) = do
     cmd <- preProcess wd menv cmd0
     let c = modCP $ (proc cmd args) { delegate_ctlc = True
                                     , cwd = fmap toFilePath wd