Allow passing override-env to process functions

Unfortunately we need this to pass a custom GHC executable path to stack,
since it doesn't have an option to override it on the commandline (yet?).

6 files changed, 43 insertions, 27 deletions

diff --git a/src/CabalHelper/Compiletime/Cabal.hs b/src/CabalHelper/Compiletime/Cabal.hs
index 85ab83c..ef6de8c 100644
--- a/src/CabalHelper/Compiletime/Cabal.hs
+++ b/src/CabalHelper/Compiletime/Cabal.hs
@@ -182,15 +182,15 @@ unpackCabalHackage cabalVer tmpdir variant = do
       dir = tmpdir </> cabal
       variant_opts = case variant of Pristine -> [ "--pristine" ]; _ -> []
       args = [ "get", cabal ] ++ variant_opts
-  callProcessStderr (Just tmpdir) (cabalProgram ?progs) args
+  callProcessStderr (Just tmpdir) [] (cabalProgram ?progs) args
   return $ CabalSourceDir dir
 
 unpackCabalHEAD :: Env => FilePath -> IO (CommitId, CabalSourceDir)
 unpackCabalHEAD tmpdir = do
   let dir = tmpdir </> "cabal-head.git"
       url = "https://github.com/haskell/cabal.git"
-  callProcessStderr (Just "/") "git" [ "clone", "--depth=1", url, dir]
-  callProcessStderr (Just (dir </> "Cabal")) "cabal"
+  callProcessStderr (Just "/") [] "git" [ "clone", "--depth=1", url, dir]
+  callProcessStderr (Just (dir </> "Cabal")) [] "cabal"
     [ "act-as-setup", "--", "sdist"
     , "--output-directory=" ++ tmpdir </> "Cabal" ]
   commit <- takeWhile isHexDigit <$>
diff --git a/src/CabalHelper/Compiletime/Process.hs b/src/CabalHelper/Compiletime/Process.hs
index 43c3cd5..5e9bbbd 100644
--- a/src/CabalHelper/Compiletime/Process.hs
+++ b/src/CabalHelper/Compiletime/Process.hs
@@ -44,19 +44,28 @@ readProcess' exe args inp = do
   return outp
 
 
+-- | Essentially 'System.Process.callProcess' but returns exit code, has
+-- additional options and logging to stderr when verbosity is enabled.
 callProcessStderr'
-    :: Verbose => Maybe FilePath -> FilePath -> [String] -> IO ExitCode
-callProcessStderr' mwd exe args = do
+    :: Verbose => Maybe FilePath -> [(String, String)]
+    -> FilePath -> [String] -> IO ExitCode
+callProcessStderr' mwd env exe args = do
   let cd = case mwd of
              Nothing -> []; Just wd -> [ "cd", formatProcessArg wd++";" ]
   vLog $ intercalate " " $ cd ++ map formatProcessArg (exe:args)
-  (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr
-                                                , cwd = mwd }
+  (_, _, _, h) <- createProcess (proc exe args)
+    { std_out = UseHandle stderr
+    , env = if env == [] then Nothing else Just env
+    , cwd = mwd
+    }
   waitForProcess h
 
-callProcessStderr :: Verbose => Maybe FilePath -> FilePath -> [String] -> IO ()
-callProcessStderr mwd exe args = do
-  rv <- callProcessStderr' mwd exe args
+-- | Essentially 'System.Process.callProcess' but with additional options
+-- and logging to stderr when verbosity is enabled.
+callProcessStderr :: Verbose => Maybe FilePath -> [(String, String)]
+                  -> FilePath -> [String] -> IO ()
+callProcessStderr mwd env exe args = do
+  rv <- callProcessStderr' mwd env exe args
   case rv of
     ExitSuccess -> return ()
     ExitFailure v -> processFailedException "callProcessStderr" exe args v
diff --git a/src/CabalHelper/Compiletime/Program/CabalInstall.hs b/src/CabalHelper/Compiletime/Program/CabalInstall.hs
index 2af1cdc..7276d81 100644
--- a/src/CabalHelper/Compiletime/Program/CabalInstall.hs
+++ b/src/CabalHelper/Compiletime/Program/CabalInstall.hs
@@ -130,7 +130,7 @@ callCabalInstall
         , [ "--only-dependencies" ]
       ]
 
-  callProcessStderr (Just "/") (cabalProgram ?progs) cabal_opts
+  callProcessStderr (Just "/") [] (cabalProgram ?progs) cabal_opts
 
   runSetupHs ghcVer db srcdir unpackedCabalVer civ
 
@@ -146,11 +146,11 @@ runSetupHs
     -> IO ()
 runSetupHs ghcVer db srcdir cabalVer CabalInstallVersion {..}
     | cabalInstallVer >= parseVer "1.24" = do
-      go $ \args -> callProcessStderr (Just srcdir) (cabalProgram ?progs) $
+      go $ \args -> callProcessStderr (Just srcdir) [] (cabalProgram ?progs) $
         [ "act-as-setup", "--" ] ++ args
     | otherwise = do
       SetupProgram {..} <- compileSetupHs ghcVer db srcdir
-      go $ callProcessStderr (Just srcdir) setupProgram
+      go $ callProcessStderr (Just srcdir) [] setupProgram
   where
     parmake_opt :: Maybe Int -> [String]
     parmake_opt nproc'
@@ -180,7 +180,7 @@ compileSetupHs (GhcVersion ghcVer) db srcdir = do
 
       file = srcdir </> "Setup"
 
-  callProcessStderr (Just srcdir) (ghcProgram ?progs) $ concat
+  callProcessStderr (Just srcdir) [] (ghcProgram ?progs) $ concat
     [ [ "--make"
       , "-package-conf", db
       ]
@@ -232,7 +232,7 @@ installCabalLibV2 _ghcVer cv (PackageEnvFile env_file) = do
              | ?verbose 4 -> ["-v3"]
              | otherwise -> []
         ]
-    callProcessStderr (Just cwd) (cabalProgram ?progs) cabal_opts
+    callProcessStderr (Just cwd) [] (cabalProgram ?progs) cabal_opts
     hPutStrLn stderr "done"
 
 
diff --git a/src/CabalHelper/Compiletime/Program/GHC.hs b/src/CabalHelper/Compiletime/Program/GHC.hs
index e45d921..a42406c 100644
--- a/src/CabalHelper/Compiletime/Program/GHC.hs
+++ b/src/CabalHelper/Compiletime/Program/GHC.hs
@@ -81,7 +81,7 @@ createPkgDb cabalVer = do
     <- getPrivateCabalPkgDb $ unpackedToResolvedCabalVersion cabalVer
   exists <- doesDirectoryExist db_path
   when (not exists) $
-       callProcessStderr Nothing (ghcPkgProgram ?progs) ["init", db_path]
+       callProcessStderr Nothing [] (ghcPkgProgram ?progs) ["init", db_path]
   return db
 
 getPrivateCabalPkgDb :: (Verbose, Progs) => ResolvedCabalVersion -> IO PackageDbDir
@@ -136,7 +136,7 @@ cabalVersionExistsInPkgDb cabalVer db@(PackageDbDir db_path) = do
 
 invokeGhc :: Env => GhcInvocation -> IO (Either ExitCode FilePath)
 invokeGhc GhcInvocation {..} = do
-    rv <- callProcessStderr' Nothing (ghcProgram ?progs) $ concat
+    rv <- callProcessStderr' (Just "/") [] (ghcProgram ?progs) $ concat
       [ [ "-outputdir", giOutDir
         , "-o", giOutput
         ]
diff --git a/src/CabalHelper/Compiletime/Program/Stack.hs b/src/CabalHelper/Compiletime/Program/Stack.hs
index 3cdf87b..896c73e 100644
--- a/src/CabalHelper/Compiletime/Program/Stack.hs
+++ b/src/CabalHelper/Compiletime/Program/Stack.hs
@@ -112,14 +112,14 @@ listPackageCabalFiles qe@QueryEnv{qeProjLoc=ProjLocStackYaml stack_yaml}
 workdirArg :: QueryEnvI c 'Stack -> [String]
 workdirArg QueryEnv{qeDistDir=DistDirStack mworkdir} =
   maybeToList $ ("--work-dir="++) . unRelativePath <$> mworkdir
-workdirArg QueryEnv{qeDistDir=DistDirCabal{}} =
-  error "workdirArg: TODO: this case is impossible and should not produce an exhaustiveness warning anymore starting with GHC 8.8"
 
-doStackCmd :: (QueryEnvI c 'Stack -> CallProcessWithCwd a)
-           -> QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO a
+doStackCmd :: (QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv a)
+           -> QueryEnvI c 'Stack
+           -> Maybe FilePath -> [String] -> IO a
 doStackCmd procfn qe mcwd args =
   let Programs{..} = qePrograms qe in
-  procfn qe mcwd stackProgram $ stackArgsBefore ++ args ++ stackArgsAfter
+  procfn qe mcwd stackEnv stackProgram $
+    stackArgsBefore ++ args ++ stackArgsAfter
 
 readStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO String
 callStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO ()
diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs
index 1f3bd3d..330fdbc 100644
--- a/src/CabalHelper/Compiletime/Types.hs
+++ b/src/CabalHelper/Compiletime/Types.hs
@@ -231,12 +231,12 @@ data Ex a = forall x. Ex (a x)
 type QueryEnv = QueryEnvI QueryCache
 
 data QueryEnvI c (pt :: ProjType) = QueryEnv
-    { qeReadProcess :: !ReadProcessWithCwd
+    { qeReadProcess :: !ReadProcessWithCwdAndEnv
     -- ^ Field accessor for 'QueryEnv'. Function used to to start
     -- processes. Useful if you need to, for example, redirect standard error
     -- output of programs started by cabal-helper.
 
-    , qeCallProcess :: !(CallProcessWithCwd ())
+    , qeCallProcess :: !(CallProcessWithCwdAndEnv ())
 
     , qePrograms     :: !Programs
     -- ^ Field accessor for 'QueryEnv'.
@@ -255,8 +255,11 @@ data QueryEnvI c (pt :: ProjType) = QueryEnv
     -- 'QueryEnv' is used.
     }
 
-type ReadProcessWithCwd   = String -> CallProcessWithCwd String
-type CallProcessWithCwd a = Maybe FilePath -> FilePath -> [String] -> IO a
+type ReadProcessWithCwdAndEnv   =
+  String -> CallProcessWithCwdAndEnv String
+
+type CallProcessWithCwdAndEnv a =
+  Maybe FilePath -> [(String, String)] -> FilePath -> [String] -> IO a
 
 data QueryCache pt = QueryCache
     { qcProjInfo  :: !(Maybe (ProjInfo pt))
@@ -472,6 +475,10 @@ data Programs = Programs
       -- ^ The path to the @stack@ program.
     , stackArgsBefore :: ![String]
     , stackArgsAfter  :: ![String]
+    , stackEnv        :: ![(String, String)]
+      --  ^ TODO: Stack doesn't support passing the compiler as a
+      --  commandline option so we meddle with PATH instead. We should
+      --  patch that upstream.
 
     , ghcProgram    :: !FilePath
     -- ^ The path to the @ghc@ program.
@@ -484,7 +491,7 @@ data Programs = Programs
 -- | By default all programs use their unqualified names, i.e. they will be
 -- searched for on @PATH@.
 defaultPrograms :: Programs
-defaultPrograms = Programs "cabal" [] []  "stack" [] [] "ghc" "ghc-pkg"
+defaultPrograms = Programs "cabal" [] []  "stack" [] [] [] "ghc" "ghc-pkg"
 
 data CompileOptions = CompileOptions
     { oVerbose       :: Bool