aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Distribution/Helper.hs22
-rw-r--r--src/CabalHelper/Compiletime/Cabal.hs6
-rw-r--r--src/CabalHelper/Compiletime/Process.hs23
-rw-r--r--src/CabalHelper/Compiletime/Program/CabalInstall.hs10
-rw-r--r--src/CabalHelper/Compiletime/Program/GHC.hs4
-rw-r--r--src/CabalHelper/Compiletime/Program/Stack.hs10
-rw-r--r--src/CabalHelper/Compiletime/Types.hs17
-rw-r--r--tests/GhcSession.hs4
8 files changed, 58 insertions, 38 deletions
diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs
index c269a5c..209eb09 100644
--- a/lib/Distribution/Helper.hs
+++ b/lib/Distribution/Helper.hs
@@ -196,12 +196,16 @@ mkQueryEnv
mkQueryEnv projloc distdir = do
cr <- newIORef $ QueryCache Nothing Map.empty
return $ QueryEnv
- { qeReadProcess = \stdin mcwd exe args ->
- readCreateProcess (proc exe args){ cwd = mcwd } stdin
- , qeCallProcess = \mcwd exe args -> do
+ { qeReadProcess = \stdin mcwd env exe args ->
+ let cp = (proc exe args)
+ { cwd = mcwd
+ , env = if env == [] then Nothing else Just env
+ }
+ in readCreateProcess cp stdin
+ , qeCallProcess = \mcwd env exe args -> do
let ?verbose = \_ -> False -- TODO: we should get this from env or
-- something
- callProcessStderr mcwd exe args
+ callProcessStderr mcwd env exe args
, qePrograms = defaultPrograms
, qeProjLoc = projloc
, qeDistDir = distdir
@@ -378,13 +382,13 @@ shallowReconfigureProject QueryEnv
{ qeProjLoc = ProjLocV2File projfile
, qeDistDir = DistDirCabal SCV2 _distdirv2, .. } = do
let projdir = takeDirectory projfile
- _ <- qeCallProcess (Just projdir) (cabalProgram qePrograms)
+ _ <- qeCallProcess (Just projdir) [] (cabalProgram qePrograms)
["new-build", "--dry-run", "--project-file="++projfile, "all"]
return ()
shallowReconfigureProject QueryEnv
{ qeProjLoc = ProjLocV2Dir projdir
, qeDistDir = DistDirCabal SCV2 _distdirv2, .. } = do
- _ <- qeCallProcess (Just projdir) (cabalProgram qePrograms)
+ _ <- qeCallProcess (Just projdir) [] (cabalProgram qePrograms)
["new-build", "--dry-run", "all"]
return ()
shallowReconfigureProject QueryEnv
@@ -403,7 +407,7 @@ reconfigureUnit
QueryEnv{qeProjLoc=ProjLocV2File projfile, ..}
Unit{uPackageDir, uImpl}
= do
- _ <- qeCallProcess (Just uPackageDir) (cabalProgram qePrograms)
+ _ <- qeCallProcess (Just uPackageDir) [] (cabalProgram qePrograms)
(["new-build", "--project-file="++projfile]
++ uiV2Components uImpl)
return ()
@@ -411,7 +415,7 @@ reconfigureUnit
QueryEnv{qeProjLoc=ProjLocV2Dir{}, ..}
Unit{uPackageDir, uImpl}
= do
- _ <- qeCallProcess (Just uPackageDir) (cabalProgram qePrograms)
+ _ <- qeCallProcess (Just uPackageDir) [] (cabalProgram qePrograms)
(["new-build"] ++ uiV2Components uImpl)
-- TODO: version check for --only-configure
return ()
@@ -546,7 +550,7 @@ invokeHelper
args0
= do
let args1 = cabal_file_path : distdir : args0
- evaluate =<< qeReadProcess "" Nothing exe args1 `E.catch`
+ evaluate =<< qeReadProcess "" Nothing [] exe args1 `E.catch`
\(_ :: E.IOException) ->
panicIO $ concat
["invokeHelper", ": ", exe, " "
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
diff --git a/tests/GhcSession.hs b/tests/GhcSession.hs
index 52eba4e..9dafae1 100644
--- a/tests/GhcSession.hs
+++ b/tests/GhcSession.hs
@@ -299,12 +299,12 @@ runTest modProgs ps2@(psdImpl -> ProjSetupImpl{..}) topdir projdir cabal_file
runWithCwd :: FilePath -> String -> [String] -> IO ()
runWithCwd cwd x xs = do
let ?verbose = (==1)
- callProcessStderr (Just cwd) x xs
+ callProcessStderr (Just cwd) [] x xs
run :: String -> [String] -> IO ()
run x xs = do
let ?verbose = (==1)
- callProcessStderr Nothing x xs
+ callProcessStderr Nothing [] x xs
test
:: ModProgs -> ProjSetup2 pt
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-10 23:48:45 +0000