From 23864c59abfc6dad5a6b137941d618903817e1e3 Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sun, 4 Aug 2019 21:14:45 +0200 Subject: 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?). --- lib/Distribution/Helper.hs | 22 ++++++++++++--------- src/CabalHelper/Compiletime/Cabal.hs | 6 +++--- src/CabalHelper/Compiletime/Process.hs | 23 +++++++++++++++------- .../Compiletime/Program/CabalInstall.hs | 10 +++++----- src/CabalHelper/Compiletime/Program/GHC.hs | 4 ++-- src/CabalHelper/Compiletime/Program/Stack.hs | 10 +++++----- src/CabalHelper/Compiletime/Types.hs | 17 +++++++++++----- tests/GhcSession.hs | 4 ++-- 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 -- cgit v1.2.3